diff options
author | doyougnu <jeffrey.young@iohk.io> | 2021-12-14 13:04:17 -0800 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-12-22 00:12:27 -0500 |
commit | 1a596d069991255e196621d06a046f60359f3129 (patch) | |
tree | 899cf688c007b92e4d96b839f18d0579eb9793e2 | |
parent | ff657a81ae5ebd4ea4628ca8ebc88dce3ecbe0ef (diff) | |
download | haskell-1a596d069991255e196621d06a046f60359f3129.tar.gz |
Cmm: DynFlags to CmmConfig refactor
add files GHC.Cmm.Config, GHC.Driver.Config.Cmm
Cmm: DynFlag references --> CmmConfig
Cmm.Pipeline: reorder imports, add handshake
Cmm: DynFlag references --> CmmConfig
Cmm.Pipeline: DynFlag references --> CmmConfig
Cmm.LayoutStack: DynFlag references -> CmmConfig
Cmm.Info.Build: DynFlag references -> CmmConfig
Cmm.Config: use profile to retrieve platform
Cmm.CLabel: unpack NCGConfig in labelDynamic
Cmm.Config: reduce CmmConfig surface area
Cmm.Config: add cmmDoCmmSwitchPlans field
Cmm.Config: correct cmmDoCmmSwitchPlans flag
The original implementation dispatches work in cmmImplementSwitchPlans
in an `otherwise` branch, hence we must add a not to correctly dispatch
Cmm.Config: add cmmSplitProcPoints simplify Config
remove cmmBackend, and cmmPosInd
Cmm.CmmToAsm: move ncgLabelDynamic to CmmToAsm
Cmm.CLabel: remove cmmLabelDynamic function
Cmm.Config: rename cmmOptDoLinting -> cmmDoLinting
testsuite: update CountDepsAst CountDepsParser
-rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 25 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Config.hs | 32 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Info/Build.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/Cmm/LayoutStack.hs | 55 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 66 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Switch/Implement.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/PIC.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Cmm.hs | 33 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
-rw-r--r-- | testsuite/tests/count-deps/CountDepsAst.stdout | 3 | ||||
-rw-r--r-- | testsuite/tests/count-deps/CountDepsParser.stdout | 3 |
11 files changed, 175 insertions, 114 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index fad545f662..de608bafd4 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -152,7 +152,6 @@ import GHC.Platform import GHC.Types.Unique.Set import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) -import GHC.CmmToAsm.Config import GHC.Types.SrcLoc -- ----------------------------------------------------------------------------- @@ -1177,21 +1176,21 @@ isLocalCLabel this_mod lbl = -- that data resides in a DLL or not. [Win32 only.] -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: NCGConfig -> CLabel -> Bool -labelDynamic config lbl = +labelDynamic :: Module -> Platform -> Bool -> CLabel -> Bool +labelDynamic this_mod platform external_dynamic_refs lbl = case lbl of -- is the RTS in a DLL or not? RtsLabel _ -> - externalDynamicRefs && (this_unit /= rtsUnitId) + external_dynamic_refs && (this_unit /= rtsUnitId) IdLabel n _ _ -> - externalDynamicRefs && isDynLinkName platform this_mod n + external_dynamic_refs && isDynLinkName platform this_mod n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library. CmmLabel lbl_unit _ _ _ - | os == OSMinGW32 -> externalDynamicRefs && (this_unit /= lbl_unit) - | otherwise -> externalDynamicRefs + | os == OSMinGW32 -> external_dynamic_refs && (this_unit /= lbl_unit) + | otherwise -> external_dynamic_refs LocalBlockLabel _ -> False @@ -1209,7 +1208,7 @@ labelDynamic config lbl = -- When compiling in the "dyn" way, each package is to be -- linked into its own DLL. ForeignLabelInPackage pkgId -> - externalDynamicRefs && (this_unit /= pkgId) + external_dynamic_refs && (this_unit /= pkgId) else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic @@ -1217,25 +1216,21 @@ labelDynamic config lbl = True CC_Label cc -> - externalDynamicRefs && not (ccFromThisModule cc this_mod) + external_dynamic_refs && not (ccFromThisModule cc this_mod) -- CCS_Label always contains a CostCentre defined in the current module CCS_Label _ -> False IPE_Label {} -> True HpcTicksLabel m -> - externalDynamicRefs && this_mod /= m + external_dynamic_refs && this_mod /= m -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False where - externalDynamicRefs = ncgExternalDynamicRefs config - platform = ncgPlatform config - os = platformOS platform - this_mod = ncgThisModule config + os = platformOS platform this_unit = toUnitId (moduleUnit this_mod) - ----------------------------------------------------------------------------- -- Printing out CLabels. diff --git a/compiler/GHC/Cmm/Config.hs b/compiler/GHC/Cmm/Config.hs new file mode 100644 index 0000000000..12eb4e47dc --- /dev/null +++ b/compiler/GHC/Cmm/Config.hs @@ -0,0 +1,32 @@ +-- | Cmm compilation configuration + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Cmm.Config + ( CmmConfig(..) + , cmmPlatform + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Profile + + +data CmmConfig = CmmConfig + { cmmProfile :: !Profile -- ^ Target Profile + , cmmOptControlFlow :: !Bool -- ^ Optimize Cmm Control Flow or not + , cmmDoLinting :: !Bool -- ^ Do Cmm Linting Optimization or not + , cmmOptElimCommonBlks :: !Bool -- ^ Eliminate common blocks or not + , cmmOptSink :: !Bool -- ^ Perform sink after stack layout or not + , cmmGenStackUnwindInstr :: !Bool -- ^ Generate stack unwinding instructions (for debugging) + , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries + , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements + , cmmSplitProcPoints :: !Bool -- ^ Should Cmm split proc points or not + } + +-- | retrieve the target Cmm platform +cmmPlatform :: CmmConfig -> Platform +cmmPlatform = profilePlatform . cmmProfile + diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 191415274e..01f3c2a3ff 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -23,6 +23,7 @@ import GHC.Platform.Profile import GHC.Types.Id import GHC.Types.Id.Info import GHC.Cmm.BlockId +import GHC.Cmm.Config import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label @@ -33,7 +34,6 @@ import GHC.Data.Graph.Directed import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils -import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic @@ -41,7 +41,6 @@ import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap -import GHC.Driver.Config.CmmToAsm import Control.Monad import Data.Map.Strict (Map) @@ -793,16 +792,16 @@ resolveCAF platform srtMap lbl@(CAFLabel l) = -- declarations to the ModuleSRTInfo. -- doSRTs - :: DynFlags + :: CmmConfig -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)] -> IO (ModuleSRTInfo, [CmmDeclSRTs]) -doSRTs dflags moduleSRTInfo procs data_ = do +doSRTs cfg moduleSRTInfo procs data_ = do us <- mkSplitUniqSupply 'u' - let profile = targetProfile dflags + let profile = cmmProfile cfg -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv. @@ -827,7 +826,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do decls = map snd data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) - platform = targetPlatform dflags + platform = cmmPlatform cfg -- Put the decls in dependency order. Why? So that we can implement -- [Inline] and [Filter]. If we need to refer to an SRT that has @@ -860,9 +859,9 @@ doSRTs dflags moduleSRTInfo procs data_ = do (result, moduleSRTInfo') = initUs_ us $ flip runStateT moduleSRTInfo $ do - nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs + nonCAFs <- mapM (doSCC cfg staticFuns static_data) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> - oneSRT dflags staticFuns [BlockLabel l] [cafLbl] + oneSRT cfg staticFuns [BlockLabel l] [cafLbl] True{-is a CAF-} cafs static_data return (nonCAFs ++ cAFs) @@ -904,7 +903,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do -- | Build the SRT for a strongly-connected component of blocks doSCC - :: DynFlags + :: CmmConfig -> LabelMap CLabel -- which blocks are static function entry points -> Set CLabel -- static data -> SCC (SomeLabel, CAFLabel, Set CAFLabel) @@ -915,14 +914,14 @@ doSCC , Bool -- Whether the group has CAF references ) -doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) = - oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data +doSCC cfg staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) = + oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data -doSCC dflags staticFuns static_data (CyclicSCC nodes) = do +doSCC cfg staticFuns static_data (CyclicSCC nodes) = do -- build a single SRT for the whole cycle, see Note [recursive SRTs] let (lbls, caf_lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets - oneSRT dflags staticFuns lbls caf_lbls False cafs static_data + oneSRT cfg staticFuns lbls caf_lbls False cafs static_data {- Note [recursive SRTs] @@ -951,7 +950,7 @@ references to static function closures. -- | Build an SRT for a set of blocks oneSRT - :: DynFlags + :: CmmConfig -> LabelMap CLabel -- which blocks are static function entry points -> [SomeLabel] -- blocks in this set -> [CAFLabel] -- labels for those blocks @@ -965,15 +964,14 @@ oneSRT , Bool -- Whether the group has CAF references ) -oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do +oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data = do topSRT <- get let this_mod = thisModule topSRT - config = initNCGConfig dflags this_mod - profile = targetProfile dflags + profile = cmmProfile cfg platform = profilePlatform profile - srtMap = moduleSRTMap topSRT + srtMap = moduleSRTMap topSRT blockids = getBlockLabels lbls @@ -1070,7 +1068,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do -- when dynamic linking is used we cannot guarantee that the offset -- between the SRT and the info table will fit in the offset field. -- Consequently we build a singleton SRT in this case. - not (labelDynamic config lbl) + not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl) -- MachO relocations can't express offsets between compilation units at -- all, so we are always forced to build a singleton SRT in this case. diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index b996427bba..ad13e8f431 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -15,6 +15,7 @@ import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layer import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.BlockId +import GHC.Cmm.Config import GHC.Cmm.Utils import GHC.Cmm.Graph import GHC.Cmm.Liveness @@ -30,7 +31,6 @@ import GHC.Data.Maybe import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Driver.Session import GHC.Utils.Outputable hiding ( isEmpty ) import GHC.Utils.Panic import qualified Data.Set as Set @@ -235,21 +235,21 @@ instance Outputable StackMap where text "sm_regs = " <> pprUFM sm_regs ppr -cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph +cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph -> UniqSM (CmmGraph, LabelMap StackMap) -cmmLayoutStack dflags procpoints entry_args +cmmLayoutStack cfg procpoints entry_args graph@(CmmGraph { g_entry = entry }) = do -- We need liveness info. Dead assignments are removed later -- by the sinking pass. let liveness = cmmLocalLiveness platform graph - blocks = revPostorder graph - profile = targetProfile dflags + blocks = revPostorder graph + profile = cmmProfile cfg platform = profilePlatform profile (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> - layout dflags procpoints liveness entry entry_args + layout cfg procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks blocks_with_reloads <- @@ -261,7 +261,7 @@ cmmLayoutStack dflags procpoints entry_args -- Pass 1 -- ----------------------------------------------------------------------------- -layout :: DynFlags +layout :: CmmConfig -> LabelSet -- proc points -> LabelMap CmmLocalLive -- liveness -> BlockId -- entry @@ -278,7 +278,7 @@ layout :: DynFlags , [CmmBlock] -- [out] new blocks ) -layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks +layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high blocks = go blocks init_stackmap entry_args [] where (updfr, cont_info) = collectContInfo blocks @@ -311,7 +311,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high -- each of the successor blocks. See handleLastNode for -- details. (middle1, sp_off, last1, fixup_blocks, out) - <- handleLastNode dflags procpoints liveness cont_info + <- handleLastNode cfg procpoints liveness cont_info acc_stackmaps stack1 tscope middle0 last0 -- (c) Manifest Sp: run over the nodes in the block and replace @@ -326,7 +326,7 @@ layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1 let final_blocks = - manifestSp dflags final_stackmaps stack0 sp0 final_sp_high + manifestSp cfg final_stackmaps stack0 sp0 final_sp_high entry0 middle_pre sp_off last1 fixup_blocks let acc_stackmaps' = mapUnion acc_stackmaps out @@ -433,7 +433,7 @@ getStackLoc (Young l) n stackmaps = -- extra code that goes *after* the Sp adjustment. handleLastNode - :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff + :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff -> LabelMap StackMap -> StackMap -> CmmTickScope -> Block CmmNode O O -> CmmNode O C @@ -445,7 +445,7 @@ handleLastNode , LabelMap StackMap -- stackmaps for the continuations ) -handleLastNode dflags procpoints liveness cont_info stackmaps +handleLastNode cfg procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } tscp middle last = case last of -- At each return / tail call, @@ -467,7 +467,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps CmmCondBranch {} -> handleBranches CmmSwitch {} -> handleBranches where - platform = targetPlatform dflags + platform = cmmPlatform cfg -- Calls and ForeignCalls are handled the same way: lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff -> ( [CmmNode O O] @@ -544,7 +544,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps | Just stack2 <- mapLookup l stackmaps = do let assigs = fixupStack stack0 stack2 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs return (l, tmp_lbl, stack2, block) -- (b) if the successor is a proc point, save everything @@ -555,7 +555,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps (stack2, assigs) = setupStackFrame platform l liveness (sm_ret_off stack0) cont_args stack0 - (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs + (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs return (l, tmp_lbl, stack2, block) -- (c) otherwise, the current StackMap is the StackMap for @@ -569,16 +569,16 @@ handleLastNode dflags procpoints liveness cont_info stackmaps is_live (r,_) = r `elemRegSet` live -makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap +makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap -> CmmTickScope -> [CmmNode O O] -> UniqSM (Label, [CmmBlock]) -makeFixupBlock dflags sp0 l stack tscope assigs +makeFixupBlock cfg sp0 l stack tscope assigs | null assigs && sp0 == sm_sp stack = return (l, []) | otherwise = do tmp_lbl <- newBlockId let sp_off = sp0 - sm_sp stack block = blockJoin (CmmEntry tmp_lbl tscope) - ( maybeAddSpAdj dflags sp0 sp_off + ( maybeAddSpAdj cfg sp0 sp_off $ blockFromList assigs ) (CmmBranch l) return (tmp_lbl, [block]) @@ -822,7 +822,7 @@ allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0 -- middle_post, because the Sp adjustment intervenes. -- manifestSp - :: DynFlags + :: CmmConfig -> LabelMap StackMap -- StackMaps for other blocks -> StackMap -- StackMap for this block -> ByteOff -- Sp on entry to the block @@ -834,18 +834,18 @@ manifestSp -> [CmmBlock] -- new blocks -> [CmmBlock] -- final blocks with Sp manifest -manifestSp dflags stackmaps stack0 sp0 sp_high +manifestSp cfg stackmaps stack0 sp0 sp_high first middle_pre sp_off last fixup_blocks = final_block : fixup_blocks' where area_off = getAreaOff stackmaps - platform = targetPlatform dflags + platform = cmmPlatform cfg adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off) adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off) - final_middle = maybeAddSpAdj dflags sp0 sp_off + final_middle = maybeAddSpAdj cfg sp0 sp_off . blockFromList . map adj_pre_sp . elimStackStores stack0 stackmaps area_off @@ -865,11 +865,12 @@ getAreaOff stackmaps (Young l) = maybeAddSpAdj - :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O -maybeAddSpAdj dflags sp0 sp_off block = + :: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj cfg sp0 sp_off block = add_initial_unwind $ add_adj_unwind $ adj block where - platform = targetPlatform dflags + platform = cmmPlatform cfg + do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg adj block | sp_off /= 0 = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off) @@ -877,7 +878,7 @@ maybeAddSpAdj dflags sp0 sp_off block = -- Add unwind pseudo-instruction at the beginning of each block to -- document Sp level for debugging add_initial_unwind block - | debugLevel dflags > 0 + | do_stk_unwinding_gen = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block | otherwise = block @@ -886,7 +887,7 @@ maybeAddSpAdj dflags sp0 sp_off block = -- Add unwind pseudo-instruction right after the Sp adjustment -- if there is one. add_adj_unwind block - | debugLevel dflags > 0 + | do_stk_unwinding_gen , sp_off /= 0 = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] | otherwise diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 7de0ce0cb8..270a281461 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -10,19 +10,20 @@ module GHC.Cmm.Pipeline ( import GHC.Prelude import GHC.Cmm -import GHC.Cmm.Lint -import GHC.Cmm.Info.Build -import GHC.Cmm.CommonBlockElim -import GHC.Cmm.Switch.Implement -import GHC.Cmm.ProcPoint +import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt +import GHC.Cmm.CommonBlockElim +import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Info.Build +import GHC.Cmm.Lint import GHC.Cmm.LayoutStack +import GHC.Cmm.ProcPoint import GHC.Cmm.Sink -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Switch.Implement import GHC.Types.Unique.Supply import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Config.Cmm import GHC.Utils.Error import GHC.Utils.Logger import GHC.Driver.Env @@ -43,23 +44,23 @@ cmmPipeline -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- cmmPipeline hsc_env srtInfo prog = do - let logger = hsc_logger hsc_env - let dflags = hsc_dflags hsc_env - let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group - let platform = targetPlatform dflags + let logger = hsc_logger hsc_env + let cmmConfig = initCmmConfig (hsc_dflags hsc_env) + let forceRes (info, group) = info `seq` foldr seq () group + let platform = cmmPlatform cmmConfig withTimingSilent logger (text "Cmm pipeline") forceRes $ do - tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform dflags) prog + tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog let (procs, data_) = partitionEithers tops - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_ dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) -cpsTop :: Logger -> Platform -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +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 dflags proc = +cpsTop logger platform cfg proc = do ----------- Control-flow optimisations ---------------------------------- @@ -76,15 +77,17 @@ cpsTop logger platform dflags proc = ----------- Eliminate common blocks ------------------------------------- g <- {-# SCC "elimCommonBlocks" #-} - condPass Opt_CmmElimCommonBlocks elimCommonBlocks g + condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g Opt_D_dump_cmm_cbe "Post common block elimination" -- Any work storing block Labels must be performed _after_ -- elimCommonBlocks ----------- Implement switches ------------------------------------------ - g <- {-# SCC "createSwitchPlans" #-} - runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g + g <- if cmmDoCmmSwitchPlans cfg + then {-# SCC "createSwitchPlans" #-} + runUniqSM $ cmmImplementSwitchPlans platform g + else pure g dump Opt_D_dump_cmm_switch "Post switch plan" g ----------- Proc points ------------------------------------------------- @@ -106,13 +109,13 @@ cpsTop logger platform dflags proc = (g, stackmaps) <- {-# SCC "layoutStack" #-} if do_layout - then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g + then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g else return (g, mapEmpty) dump Opt_D_dump_cmm_sp "Layout Stack" g ----------- Sink and inline assignments -------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass Opt_CmmSink (cmmSink platform) g + condPass (cmmOptSink cfg) (cmmSink platform) g Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ---------------------------------------------- @@ -142,7 +145,7 @@ cpsTop logger platform dflags proc = ----------- Control-flow optimisations ----------------------------- g <- {-# SCC "cmmCfgOpts(2)" #-} - return $ if gopt Opt_CmmControlFlow dflags + return $ if cmmOptControlFlow cfg then map (cmmCfgOptsProc splitting_proc_points) g else g g <- return (map removeUnreachableBlocksProc g) @@ -151,13 +154,13 @@ cpsTop logger platform dflags proc = return (Left (cafEnv, g)) - where dump = dumpGraph logger platform dflags + where dump = dumpGraph logger platform (cmmDoLinting cfg) dumps flag name = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform) - condPass flag pass g dumpflag dumpname = - if gopt flag dflags + condPass do_opt pass g dumpflag dumpname = + if do_opt then do g <- return $ pass g dump dumpflag dumpname g @@ -168,14 +171,7 @@ cpsTop logger platform dflags proc = -- tablesNextToCode is off. The latter is because we have no -- label to put on info tables for basic blocks that are not -- the entry point. - splitting_proc_points = backend dflags /= NCG - || not (platformTablesNextToCode platform) - || -- Note [inconsistent-pic-reg] - usingInconsistentPicReg - usingInconsistentPicReg - = case (platformArch platform, platformOS platform, positionIndependent dflags) - of (ArchX86, OSDarwin, pic) -> pic - _ -> False + splitting_proc_points = cmmSplitProcPoints cfg -- Note [Sinking after stack layout] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -347,9 +343,9 @@ runUniqSM m = do return (initUs_ us m) -dumpGraph :: Logger -> Platform -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph logger platform dflags flag name g = do - when (gopt Opt_DoCmmLinting dflags) $ do_lint g +dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger platform do_linting flag name g = do + when do_linting $ do_lint g dumpWith logger flag name FormatCMM (pdoc platform g) where do_lint g = case cmmLintGraph platform g of diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs index 7b0ad6107a..87dfc1cdaa 100644 --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -6,7 +6,6 @@ where import GHC.Prelude -import GHC.Driver.Backend import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId @@ -32,11 +31,10 @@ import GHC.Utils.Monad (concatMapM) -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation. -cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph -cmmImplementSwitchPlans backend platform g +cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph +cmmImplementSwitchPlans platform g = -- Switch generation done by backend (LLVM/C) - | backendSupportsSwitch backend = return g - | otherwise = do + do blocks' <- concatMapM (visitSwitches platform) (toBlockList g) return $ ofBlockList (g_entry g) blocks' diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index 10ddaa1f5f..8a728102e5 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -209,6 +209,13 @@ absoluteLabel lbl -- pointers, code stubs and GOT offsets look like is located in the -- module CLabel. +-- | Helper to check whether the data resides in a DLL or not, see @labelDynamic@ +ncgLabelDynamic :: NCGConfig -> CLabel -> Bool +ncgLabelDynamic config = labelDynamic (ncgThisModule config) + (ncgPlatform config) + (ncgExternalDynamicRefs config) + + -- We have to decide which labels need to be accessed -- indirectly or via a piece of stub code. data LabelAccessStyle @@ -247,7 +254,7 @@ howToAccessLabel config _arch OSMinGW32 _kind lbl -- If the target symbol is in another PE we need to access it via the -- appropriate __imp_SYMBOL pointer. - | labelDynamic config lbl + | ncgLabelDynamic config lbl = AccessViaSymbolPtr -- Target symbol is in the same PE as the caller, so just access it directly. @@ -262,7 +269,7 @@ howToAccessLabel config ArchAArch64 _os _kind lbl | not (ncgExternalDynamicRefs config) = AccessDirectly - | labelDynamic config lbl + | ncgLabelDynamic config lbl = AccessViaSymbolPtr | otherwise @@ -279,7 +286,7 @@ howToAccessLabel config ArchAArch64 _os _kind lbl -- howToAccessLabel config arch OSDarwin DataReference lbl -- data access to a dynamic library goes via a symbol pointer - | labelDynamic config lbl + | ncgLabelDynamic config lbl = AccessViaSymbolPtr -- when generating PIC code, all cross-module data references must @@ -300,7 +307,7 @@ howToAccessLabel config arch OSDarwin JumpReference lbl -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64 - , labelDynamic config lbl + , ncgLabelDynamic config lbl = AccessViaSymbolPtr @@ -310,7 +317,7 @@ howToAccessLabel config arch OSDarwin _kind lbl -- them automatically, neither on Aarch64 (arm64). | arch /= ArchX86_64 , arch /= ArchAArch64 - , labelDynamic config lbl + , ncgLabelDynamic config lbl = AccessViaStub | otherwise @@ -362,7 +369,7 @@ howToAccessLabel config arch os DataReference lbl | osElfTarget os = case () of -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic config lbl + _ | ncgLabelDynamic config lbl -> AccessViaSymbolPtr -- For PowerPC32 -fPIC, we have to access even static data @@ -390,18 +397,19 @@ howToAccessLabel config arch os DataReference lbl howToAccessLabel config arch os CallReference lbl | osElfTarget os - , labelDynamic config lbl && not (ncgPIC config) + , ncgLabelDynamic config lbl + , not (ncgPIC config) = AccessDirectly | osElfTarget os , arch /= ArchX86 - , labelDynamic config lbl + , ncgLabelDynamic config lbl , ncgPIC config = AccessViaStub howToAccessLabel config _arch os _kind lbl | osElfTarget os - = if labelDynamic config lbl + = if ncgLabelDynamic config lbl then AccessViaSymbolPtr else AccessDirectly diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs new file mode 100644 index 0000000000..38bab62048 --- /dev/null +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -0,0 +1,33 @@ +module GHC.Driver.Config.Cmm + ( initCmmConfig + ) where + +import GHC.Cmm.Config +import GHC.Cmm.Switch (backendSupportsSwitch) + +import GHC.Driver.Session +import GHC.Driver.Backend + +import GHC.Platform + +import GHC.Prelude + +initCmmConfig :: DynFlags -> CmmConfig +initCmmConfig dflags = CmmConfig + { cmmProfile = targetProfile dflags + , cmmOptControlFlow = gopt Opt_CmmControlFlow dflags + , cmmDoLinting = gopt Opt_DoCmmLinting dflags + , cmmOptElimCommonBlks = gopt Opt_CmmElimCommonBlocks dflags + , cmmOptSink = gopt Opt_CmmSink dflags + , cmmGenStackUnwindInstr = debugLevel dflags > 0 + , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , cmmDoCmmSwitchPlans = not . backendSupportsSwitch . backend $ dflags + , cmmSplitProcPoints = (backend dflags /= NCG) + || not (platformTablesNextToCode platform) + || usingInconsistentPicReg + } + where platform = targetPlatform dflags + usingInconsistentPicReg = + case (platformArch platform, platformOS platform, positionIndependent dflags) + of (ArchX86, OSDarwin, pic) -> pic + _ -> False diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index db3f5f3926..51315c8b75 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -167,6 +167,7 @@ Library GHC.Cmm.CallConv GHC.Cmm.CLabel GHC.Cmm.CommonBlockElim + GHC.Cmm.Config GHC.Cmm.ContFlowOpt GHC.Cmm.Dataflow GHC.Cmm.Dataflow.Block @@ -386,6 +387,7 @@ Library GHC.Driver.CmdLine GHC.Driver.CodeOutput GHC.Driver.Config + GHC.Driver.Config.Cmm GHC.Driver.Config.CmmToAsm GHC.Driver.Config.CmmToLlvm GHC.Driver.Config.Diagnostic diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index b557778846..c4d629069c 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 277 Language.Haskell.Syntax module dependencies +Found 276 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -18,7 +18,6 @@ GHC.Cmm.Node GHC.Cmm.Switch GHC.Cmm.Type GHC.CmmToAsm.CFG.Weight -GHC.CmmToAsm.Config GHC.Core GHC.Core.Class GHC.Core.Coercion diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 1e86aeb777..457e42da8e 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 283 GHC.Parser module dependencies +Found 282 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -18,7 +18,6 @@ GHC.Cmm.Node GHC.Cmm.Switch GHC.Cmm.Type GHC.CmmToAsm.CFG.Weight -GHC.CmmToAsm.Config GHC.Core GHC.Core.Class GHC.Core.Coercion |