diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-09-02 16:23:22 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-04 16:24:59 -0400 |
commit | 89ce7cdf977304cb7d0f325a013f822600c1bfbf (patch) | |
tree | baa862e1bfc0f2dab23c70353a190cc6e67d7e9d | |
parent | 1d6d648866da9e7754859c48235f8009b8c130fd (diff) | |
download | haskell-89ce7cdf977304cb7d0f325a013f822600c1bfbf.tar.gz |
DynFlags: use Platform in foldRegs*
-rw-r--r-- | compiler/GHC/Cmm/Expr.hs | 23 | ||||
-rw-r--r-- | compiler/GHC/Cmm/LayoutStack.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Lint.hs | 65 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Liveness.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Node.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Pipeline.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Cmm/ProcPoint.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Cmm/Sink.hs | 112 | ||||
-rw-r--r-- | compiler/GHC/Driver/CodeOutput.hs | 2 |
9 files changed, 138 insertions, 152 deletions
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index 9b6f160a53..08ab27c410 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -38,7 +38,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type -import GHC.Driver.Session import GHC.Utils.Panic (panic) import GHC.Types.Unique @@ -331,17 +330,17 @@ sizeRegSet = Set.size regSetToList = Set.toList class Ord r => UserOfRegs r a where - foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b + foldRegsUsed :: Platform -> (b -> r -> b) -> b -> a -> b foldLocalRegsUsed :: UserOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b + => Platform -> (b -> LocalReg -> b) -> b -> a -> b foldLocalRegsUsed = foldRegsUsed class Ord r => DefinerOfRegs r a where - foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b + foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b foldLocalRegsDefd :: DefinerOfRegs LocalReg a - => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b + => Platform -> (b -> LocalReg -> b) -> b -> a -> b foldLocalRegsDefd = foldRegsDefd instance UserOfRegs LocalReg CmmReg where @@ -369,20 +368,20 @@ instance Ord r => DefinerOfRegs r r where instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where -- The (Ord r) in the context is necessary here -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance - foldRegsUsed dflags f !z e = expr z e + foldRegsUsed platform f !z e = expr z e where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr - expr z (CmmReg r) = foldRegsUsed dflags f z r - expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs - expr z (CmmRegOff r _) = foldRegsUsed dflags f z r + expr z (CmmLoad addr _) = foldRegsUsed platform f z addr + expr z (CmmReg r) = foldRegsUsed platform f z r + expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs + expr z (CmmRegOff r _) = foldRegsUsed platform f z r expr z (CmmStackSlot _ _) = z instance UserOfRegs r a => UserOfRegs r [a] where - foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as + foldRegsUsed platform f set as = foldl' (foldRegsUsed platform f) set as {-# INLINABLE foldRegsUsed #-} instance DefinerOfRegs r a => DefinerOfRegs r [a] where - foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as + foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as {-# INLINABLE foldRegsDefd #-} ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index 9cf4638001..19358d350d 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -246,9 +246,10 @@ cmmLayoutStack dflags procpoints entry_args = do -- We need liveness info. Dead assignments are removed later -- by the sinking pass. - let liveness = cmmLocalLiveness dflags graph + let liveness = cmmLocalLiveness platform graph blocks = revPostorder graph - profile = targetProfile dflags + profile = targetProfile dflags + platform = profilePlatform profile (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> @@ -256,7 +257,7 @@ cmmLayoutStack dflags procpoints entry_args rec_stackmaps rec_high_sp blocks blocks_with_reloads <- - insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks + insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads return (ofBlockList entry new_blocks', final_stackmaps) @@ -1044,30 +1045,29 @@ stackMapToLiveness platform StackMap{..} = -- ----------------------------------------------------------------------------- insertReloadsAsNeeded - :: DynFlags + :: Platform -> ProcPointSet -> LabelMap StackMap -> BlockId -> [CmmBlock] -> UniqSM [CmmBlock] -insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do +insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do toBlockList . fst <$> rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty where rewriteCC :: RewriteFun CmmLocalLive rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do let entry_label = entryLabel e_node - platform = targetPlatform dflags stackmap = case mapLookup entry_label final_stackmaps of Just sm -> sm Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap" -- Merge the liveness from successor blocks and analyse the last -- node. - joined = gen_kill dflags x_node $! + joined = gen_kill platform x_node $! joinOutFacts liveLattice x_node fact_base0 -- What is live at the start of middle0. - live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined + live_at_middle0 = foldNodesBwdOO (gen_kill platform) middle0 joined -- If this is a procpoint we need to add the reloads, but only if -- they're actually live. Furthermore, nothing is live at the entry diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index 83932aebe6..2eccf50d0e 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -26,7 +26,6 @@ import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Utils.Outputable -import GHC.Driver.Session import Control.Monad (ap, unless) @@ -39,37 +38,38 @@ import Control.Monad (ap, unless) -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops + => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops -cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc -cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g +cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc +cmmLintGraph platform g = runCmmLint platform lintCmmGraph g -runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint dflags l p = - case unCL (l p) dflags of +runCmmLint :: Outputable a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = + case unCL (l p) platform of Left err -> Just (vcat [text "Cmm lint error:", nest 2 err, text "Program was:", nest 2 (ppr p)]) Right _ -> Nothing -lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint () -lintCmmDecl dflags (CmmProc _ lbl _ g) - = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g -lintCmmDecl _ (CmmData {}) +lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint () +lintCmmDecl (CmmProc _ lbl _ g) + = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph g +lintCmmDecl (CmmData {}) = return () -lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint () -lintCmmGraph dflags g = - cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks - -- cmmLiveness throws an error if there are registers - -- live on entry to the graph (i.e. undefined - -- variables) - where - blocks = toBlockList g - labels = setFromList (map entryLabel blocks) +lintCmmGraph :: CmmGraph -> CmmLint () +lintCmmGraph g = do + platform <- getPlatform + let + blocks = toBlockList g + labels = setFromList (map entryLabel blocks) + cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks + -- cmmLiveness throws an error if there are registers + -- live on entry to the graph (i.e. undefined + -- variables) lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint () @@ -225,9 +225,9 @@ lintTarget (PrimTarget {}) = return () mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a) => SDoc -> a -> CmmLint () mayNotMentionCallerSavedRegs what thing = do - dflags <- getDynFlags - let badRegs = filter (callerSaves (targetPlatform dflags)) - $ foldRegsUsed dflags (flip (:)) [] thing + platform <- getPlatform + let badRegs = filter (callerSaves platform) + $ foldRegsUsed platform (flip (:)) [] thing unless (null badRegs) $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing) @@ -243,7 +243,7 @@ checkCond _ expr -- just a basic error monad: -newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } +newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } deriving (Functor) instance Applicative CmmLint where @@ -251,23 +251,20 @@ instance Applicative CmmLint where (<*>) = ap instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ \dflags -> - case m dflags of + CmmLint m >>= k = CmmLint $ \platform -> + case m platform of Left e -> Left e - Right a -> unCL (k a) dflags - -instance HasDynFlags CmmLint where - getDynFlags = CmmLint (\dflags -> Right dflags) + Right a -> unCL (k a) platform getPlatform :: CmmLint Platform -getPlatform = targetPlatform <$> getDynFlags +getPlatform = CmmLint $ \platform -> Right platform cmmLintErr :: SDoc -> CmmLint a cmmLintErr msg = CmmLint (\_ -> Left msg) addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ \dflags -> - case unCL thing dflags of +addLintInfo info thing = CmmLint $ \platform -> + case unCL thing platform of Left err -> Left (hang info 2 err) Right a -> Right a diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs index c8b7993736..0ec38509ba 100644 --- a/compiler/GHC/Cmm/Liveness.hs +++ b/compiler/GHC/Cmm/Liveness.hs @@ -14,7 +14,7 @@ where import GHC.Prelude -import GHC.Driver.Session +import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances @@ -52,17 +52,17 @@ type BlockEntryLiveness r = LabelMap (CmmLive r) -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg -cmmLocalLiveness dflags graph = - check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty +cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg +cmmLocalLiveness platform graph = + check $ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty where entry = g_entry graph check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts -cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg -cmmGlobalLiveness dflags graph = - analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty +cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness platform graph = + analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a @@ -72,10 +72,10 @@ noLiveOnEntry bid in_fact x = gen_kill :: (DefinerOfRegs r n, UserOfRegs r n) - => DynFlags -> n -> CmmLive r -> CmmLive r -gen_kill dflags node set = - let !afterKill = foldRegsDefd dflags deleteFromRegSet set node - in foldRegsUsed dflags extendRegSet afterKill node + => Platform -> n -> CmmLive r -> CmmLive r +gen_kill platform node set = + let !afterKill = foldRegsDefd platform deleteFromRegSet set node + in foldRegsUsed platform extendRegSet afterKill node {-# INLINE gen_kill #-} xferLive @@ -85,10 +85,10 @@ xferLive , UserOfRegs r (CmmNode O C) , DefinerOfRegs r (CmmNode O C) ) - => DynFlags -> TransferFun (CmmLive r) -xferLive dflags (BlockCC eNode middle xNode) fBase = - let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase - !result = foldNodesBwdOO (gen_kill dflags) middle joined + => Platform -> TransferFun (CmmLive r) +xferLive platform (BlockCC eNode middle xNode) fBase = + let joined = gen_kill platform xNode $! joinOutFacts liveLattice xNode fBase + !result = foldNodesBwdOO (gen_kill platform) middle joined in mapSingleton (entryLabel eNode) result -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-} -{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-} +{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-} +{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-} diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 01db60b116..9e5b709385 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -31,7 +31,6 @@ import GHC.Prelude hiding (succ) import GHC.Platform.Regs import GHC.Cmm.Expr import GHC.Cmm.Switch -import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall import GHC.Utils.Outputable @@ -320,7 +319,7 @@ foreignTargetHints target -- Instances of register and slot users / definers instance UserOfRegs LocalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of + foldRegsUsed platform f !z n = case n of CmmAssign _ expr -> fold f z expr CmmStore addr rval -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args @@ -331,10 +330,10 @@ instance UserOfRegs LocalReg (CmmNode e x) where _ -> z where fold :: forall a b. UserOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n + fold f z n = foldRegsUsed platform f z n instance UserOfRegs GlobalReg (CmmNode e x) where - foldRegsUsed dflags f !z n = case n of + foldRegsUsed platform f !z n = case n of CmmAssign _ expr -> fold f z expr CmmStore addr rval -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args @@ -345,26 +344,26 @@ instance UserOfRegs GlobalReg (CmmNode e x) where _ -> z where fold :: forall a b. UserOfRegs GlobalReg a => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsUsed dflags f z n + fold f z n = foldRegsUsed platform f z n instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where -- The (Ord r) in the context is necessary here -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance - foldRegsUsed _ _ !z (PrimTarget _) = z - foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e + foldRegsUsed _ _ !z (PrimTarget _) = z + foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e instance DefinerOfRegs LocalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of + foldRegsDefd platform f !z n = case n of CmmAssign lhs _ -> fold f z lhs CmmUnsafeForeignCall _ fs _ -> fold f z fs CmmForeignCall {res=res} -> fold f z res _ -> z where fold :: forall a b. DefinerOfRegs LocalReg a => (b -> LocalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n + fold f z n = foldRegsDefd platform f z n instance DefinerOfRegs GlobalReg (CmmNode e x) where - foldRegsDefd dflags f !z n = case n of + foldRegsDefd platform f !z n = case n of CmmAssign lhs _ -> fold f z lhs CmmUnsafeForeignCall tgt _ _ -> fold f z (foreignTargetRegs tgt) CmmCall {} -> fold f z activeRegs @@ -373,9 +372,8 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where _ -> z where fold :: forall a b. DefinerOfRegs GlobalReg a => (b -> GlobalReg -> b) -> b -> a -> b - fold f z n = foldRegsDefd dflags f z n + fold f z n = foldRegsDefd platform f z n - platform = targetPlatform dflags activeRegs = activeStgRegs platform activeCallerSavesRegs = filter (callerSaves platform) activeRegs diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index ccf3d36a82..1335159a40 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -97,7 +97,7 @@ cpsTop dflags proc = if splitting_proc_points then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ - minimalProcPointSet (targetPlatform dflags) call_pps g + minimalProcPointSet platform call_pps g dumpWith dflags Opt_D_dump_cmm_proc "Proc points" FormatCMM (ppr l $$ ppr pp $$ ppr g) return pp @@ -114,7 +114,7 @@ cpsTop dflags proc = ----------- Sink and inline assignments -------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout] - condPass Opt_CmmSink (cmmSink dflags) g + condPass Opt_CmmSink (cmmSink platform) g Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ---------------------------------------------- @@ -129,7 +129,7 @@ cpsTop dflags proc = dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ - splitAtProcPoints dflags l call_pps proc_points pp_map + splitAtProcPoints platform l call_pps proc_points pp_map (CmmProc h l v g) dumps Opt_D_dump_cmm_split "Post splitting" g return g @@ -355,7 +355,7 @@ dumpGraph dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g dumpWith dflags flag name FormatCMM (ppr g) where - do_lint g = case cmmLintGraph dflags g of + do_lint g = case cmmLintGraph (targetPlatform dflags) g of Just err -> do { fatalErrorMsg dflags err ; ghcExit dflags 1 } diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 2de355deb3..1a0c4708da 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -11,7 +11,6 @@ where import GHC.Prelude hiding (last, unzip, succ, zip) -import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm @@ -238,9 +237,9 @@ extendPPSet platform g blocks procPoints = -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY -splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> +splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl -> UniqSM [CmmDecl] -splitAtProcPoints dflags entry_label callPPs procPoints procMap +splitAtProcPoints platform entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach @@ -262,7 +261,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph - let liveness = cmmGlobalLiveness dflags g + let liveness = cmmGlobalLiveness platform g let ppLiveness pp = filter isArgReg $ regSetToList $ expectJust "ppLiveness" $ mapLookup pp liveness @@ -316,7 +315,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap -- when jumping to a PP that has an info table, if -- tablesNextToCode is off we must jump to the entry -- label instead. - platform = targetPlatform dflags tablesNextToCode = platformTablesNextToCode platform jump_label (Just info_lbl) _ | tablesNextToCode = info_lbl diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs index 0d16411de3..8fb4f2462f 100644 --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -16,7 +16,6 @@ import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs import GHC.Platform -import GHC.Driver.Session import GHC.Types.Unique import GHC.Types.Unique.FM @@ -165,10 +164,10 @@ type Assignments = [Assignment] -- y = e2 -- x = e1 -cmmSink :: DynFlags -> CmmGraph -> CmmGraph -cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks +cmmSink :: Platform -> CmmGraph -> CmmGraph +cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where - liveness = cmmLocalLiveness dflags graph + liveness = cmmLocalLiveness platform graph getLive l = mapFindWithDefault Set.empty l liveness blocks = revPostorder graph @@ -181,7 +180,6 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- pprTrace "sink" (ppr lbl) $ blockJoin first final_middle final_last : sink sunk' bs where - platform = targetPlatform dflags lbl = entryLabel b (first, middle, last) = blockSplit b @@ -191,13 +189,13 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. live = Set.unions (map getLive succs) - live_middle = gen_kill dflags last live - ann_middles = annotate dflags live_middle (blockToList middle) + live_middle = gen_kill platform last live + ann_middles = annotate platform live_middle (blockToList middle) -- Now sink and inline in this block - (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk) + (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk) fold_last = constantFoldNode platform last - (final_last, assigs') = tryToInline dflags live fold_last assigs + (final_last, assigs') = tryToInline platform live fold_last assigs -- We cannot sink into join points (successors with more than -- one predecessor), so identify the join points and the set @@ -217,12 +215,12 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks _ -> False -- Now, drop any assignments that we will not sink any further. - (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs' + (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') where - should_drop = conflicts dflags a final_last - || not (isTrivial dflags rhs) && live_in_multi live_sets r + should_drop = conflicts platform a final_last + || not (isTrivial platform rhs) && live_in_multi live_sets r || r `Set.member` live_in_joins live_sets' | should_drop = live_sets @@ -231,12 +229,12 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks upd set | r `Set.member` set = set `Set.union` live_rhs | otherwise = set - live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs + live_rhs = foldRegsUsed platform extendRegSet emptyRegSet rhs final_middle = foldl' blockSnoc middle' dropped_last sunk' = mapUnion sunk $ - mapFromList [ (l, filterAssignments dflags (getLive l) assigs'') + mapFromList [ (l, filterAssignments platform (getLive l) assigs'') | l <- succs ] {- TODO: enable this later, when we have some good tests in place to @@ -255,12 +253,12 @@ isSmall _ = False -- We allow duplication of trivial expressions: registers (both local and -- global) and literals. -- -isTrivial :: DynFlags -> CmmExpr -> Bool +isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] - if isARM (platformArch (targetPlatform dflags)) +isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] + if isARM (platformArch platform) then True -- CodeGen.Platform.ARM does not have globalRegMaybe - else isJust (globalRegMaybe (targetPlatform dflags) r) + else isJust (globalRegMaybe platform r) -- GlobalRegs that are loads from BaseReg are not trivial isTrivial _ (CmmLit _) = True isTrivial _ _ = False @@ -268,9 +266,9 @@ isTrivial _ _ = False -- -- annotate each node with the set of registers live *after* the node -- -annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] -annotate dflags live nodes = snd $ foldr ann (live,[]) nodes - where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes) +annotate :: Platform -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)] +annotate platform live nodes = snd $ foldr ann (live,[]) nodes + where ann n (live,nodes) = (gen_kill platform n live, (live,n) : nodes) -- -- Find the blocks that have multiple successors (join points) @@ -287,14 +285,14 @@ findJoinPoints blocks = mapFilter (>1) succ_counts -- filter the list of assignments to remove any assignments that -- are not live in a continuation. -- -filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments -filterAssignments dflags live assigs = reverse (go assigs []) +filterAssignments :: Platform -> LocalRegSet -> Assignments -> Assignments +filterAssignments platform live assigs = reverse (go assigs []) where go [] kept = kept go (a@(r,_,_):as) kept | needed = go as (a:kept) | otherwise = go as kept where needed = r `Set.member` live - || any (conflicts dflags a) (map toNode kept) + || any (conflicts platform a) (map toNode kept) -- Note that we must keep assignments that are -- referred to by other assignments we have -- already kept. @@ -313,7 +311,7 @@ filterAssignments dflags live assigs = reverse (go assigs []) -- * a list of assignments that will be placed *after* that block. -- -walk :: DynFlags +walk :: Platform -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node. @@ -327,7 +325,7 @@ walk :: DynFlags , Assignments -- Assignments to sink further ) -walk dflags nodes assigs = go nodes emptyBlock assigs +walk platform nodes assigs = go nodes emptyBlock assigs where go [] block as = (block, as) go ((live,node):ns) block as @@ -336,13 +334,12 @@ walk dflags nodes assigs = go nodes emptyBlock assigs | Just a <- shouldSink platform node2 = go ns block (a : as1) | otherwise = go ns block' as' where - platform = targetPlatform dflags node1 = constantFoldNode platform node - (node2, as1) = tryToInline dflags live node1 as + (node2, as1) = tryToInline platform live node1 as - (dropped, as') = dropAssignmentsSimple dflags - (\a -> conflicts dflags a node2) as1 + (dropped, as') = dropAssignmentsSimple platform + (\a -> conflicts platform a node2) as1 block' = foldl' blockSnoc block dropped `blockSnoc` node2 @@ -380,13 +377,13 @@ shouldDiscard node live toNode :: Assignment -> CmmNode O O toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs -dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments +dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments -> ([CmmNode O O], Assignments) -dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) () +dropAssignmentsSimple platform f = dropAssignments platform (\a _ -> (f a, ())) () -dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments +dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments -> ([CmmNode O O], Assignments) -dropAssignments dflags should_drop state assigs +dropAssignments platform should_drop state assigs = (dropped, reverse kept) where (dropped,kept) = go state assigs [] [] @@ -397,7 +394,7 @@ dropAssignments dflags should_drop state assigs | otherwise = go state' rest dropped (assig:kept) where (dropit, state') = should_drop assig state - conflict = dropit || any (conflicts dflags assig) dropped + conflict = dropit || any (conflicts platform assig) dropped -- ----------------------------------------------------------------------------- @@ -406,7 +403,7 @@ dropAssignments dflags should_drop state assigs -- inlining opens up opportunities for doing so. tryToInline - :: DynFlags + :: Platform -> LocalRegSet -- set of registers live after this -- node. We cannot inline anything -- that is live after the node, unless @@ -418,10 +415,10 @@ tryToInline , Assignments -- Remaining assignments ) -tryToInline dflags live node assigs = go usages node emptyLRegSet assigs +tryToInline platform live node assigs = go usages node emptyLRegSet assigs where usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used - usages = foldLocalRegsUsed dflags addUsage emptyUFM node + usages = foldLocalRegsUsed platform addUsage emptyUFM node go _usages node _skipped [] = (node, []) @@ -429,12 +426,11 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs | cannot_inline = dont_inline | occurs_none = discard -- Note [discard during inlining] | occurs_once = inline_and_discard - | isTrivial dflags rhs = inline_and_keep + | isTrivial platform rhs = inline_and_keep | otherwise = dont_inline where - platform = targetPlatform dflags inline_and_discard = go usages' inl_node skipped rest - where usages' = foldLocalRegsUsed dflags addUsage usages rhs + where usages' = foldLocalRegsUsed platform addUsage usages rhs discard = go usages node skipped rest @@ -443,7 +439,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs keep node' = (final_node, a : rest') where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest - usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2) + usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2) usages rhs -- we must not inline anything that is mentioned in the RHS -- of a binding that we have already skipped, so we set the @@ -451,7 +447,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] || l `elemLRegSet` skipped - || not (okToInline dflags rhs node) + || not (okToInline platform rhs node) l_usages = lookupUFM usages l l_live = l `elemRegSet` live @@ -569,25 +565,25 @@ regsUsedIn ls e = wrapRecExpf f e False -- ought to be able to handle it properly, but currently neither PprC -- nor the NCG can do it. See Note [Register parameter passing] -- See also GHC.StgToCmm.Foreign.load_args_into_temps. -okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -okToInline dflags expr node@(CmmUnsafeForeignCall{}) = - not (globalRegistersConflict dflags expr node) +okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool +okToInline platform expr node@(CmmUnsafeForeignCall{}) = + not (globalRegistersConflict platform expr node) okToInline _ _ _ = True -- ----------------------------------------------------------------------------- -- | @conflicts (r,e) node@ is @False@ if and only if the assignment -- @r = e@ can be safely commuted past statement @node@. -conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool -conflicts dflags (r, rhs, addr) node +conflicts :: Platform -> Assignment -> CmmNode O x -> Bool +conflicts platform (r, rhs, addr) node -- (1) node defines registers used by rhs of assignment. This catches -- assignments and all three kinds of calls. See Note [Sinking and calls] - | globalRegistersConflict dflags rhs node = True - | localRegistersConflict dflags rhs node = True + | globalRegistersConflict platform rhs node = True + | localRegistersConflict platform rhs node = True -- (2) node uses register defined by assignment - | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True + | foldRegsUsed platform (\b r' -> r == r' || b) False node = True -- (3) a store to an address conflicts with a read of the same memory | CmmStore addr' e <- node @@ -606,21 +602,19 @@ conflicts dflags (r, rhs, addr) node -- (7) otherwise, no conflict | otherwise = False - where - platform = targetPlatform dflags -- Returns True if node defines any global registers that are used in the -- Cmm expression -globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -globalRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr) +globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool +globalRegistersConflict platform expr node = + foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr) False node -- Returns True if node defines any local registers that are used in the -- Cmm expression -localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool -localRegistersConflict dflags expr node = - foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr) +localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool +localRegistersConflict platform expr node = + foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal r) expr) False node -- Note [Sinking and calls] diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index f752449210..122efe2069 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -83,7 +83,7 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do - { case cmmLint dflags cmm of + { case cmmLint (targetPlatform dflags) cmm of Just err -> do { log_action dflags dflags NoReason |