diff options
| -rw-r--r-- | compiler/GHC/Cmm.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Info/Build.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 4 |
4 files changed, 23 insertions, 9 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 77a6574eb5..e023dcc66f 100644 --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -7,11 +7,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyCase #-} module GHC.Cmm ( -- * Cmm top-level datatypes CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, CmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmDataDecl, cmmDataDeclCmmDecl, CmmGraph, GenCmmGraph(..), toBlockMap, revPostorder, toBlockList, CmmBlock, RawCmmDecl, @@ -52,6 +55,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable +import Data.Void (Void) import Data.List (intersperse) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -116,6 +120,14 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph +type CmmDataDecl = GenCmmDataDecl CmmStatics +type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded + +cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g +cmmDataDeclCmmDecl = \ case + CmmProc void _ _ _ -> case void of + CmmData section d -> CmmData section d +{-# INLINE cmmDataDeclCmmDecl #-} type RawCmmDecl = GenCmmDecl diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index e363eb879d..16745151a4 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, - ScopedTypeVariables, OverloadedStrings, LambdaCase #-} + ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} @@ -884,7 +884,7 @@ doSRTs :: CmmConfig -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] -- ^ 'CAFEnv's and 'CmmDecl's for code blocks - -> [(CAFSet, CmmDecl)] -- ^ static data decls and their 'CAFSet's + -> [(CAFSet, CmmDataDecl)] -- ^ static data decls and their 'CAFSet's -> IO (ModuleSRTInfo, [CmmDeclSRTs]) doSRTs cfg moduleSRTInfo procs data_ = do @@ -900,8 +900,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do flip map data_ $ \(set, decl) -> case decl of - CmmProc{} -> - pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl) + CmmProc void _ _ _ -> case void of CmmData _ static -> case static of CmmStatics lbl _ _ _ _ -> (lbl, set) @@ -909,7 +908,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do (proc_envs, procss) = unzip procs cafEnv = mapUnions proc_envs - decls = map snd data_ ++ concat procss + decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) platform = cmmPlatform cfg @@ -980,8 +979,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do | otherwise -> -- Not an IdLabel, ignore srtMap - CmmProc{} -> - pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl)) + CmmProc void _ _ _ -> case void of) (moduleSRTMap moduleSRTInfo') data_ return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls') diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 9a5a5aa338..999e1bf4e6 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -67,8 +67,8 @@ cmmPipeline logger cmm_config srtInfo prog = do -- [SRTs]. -- -- - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing -cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p)) +cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl)) +cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics)) cpsTop logger platform cfg proc = do ----------- Control-flow optimisations ---------------------------------- diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 566cfd5528..0107f6fc6a 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} @@ -151,6 +152,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import Data.Time import Data.Time.Format.ISO8601 +import Data.Void import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -1173,6 +1175,8 @@ instance OutputableP env SDoc where instance (OutputableP env a) => OutputableP env (Set a) where pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s)))) +instance OutputableP env Void where + pdoc _ = \ case {- ************************************************************************ |