[Git][ghc/ghc][master] 2 commits: DynFlags: use Platform in foldRegs*
Marge Bot
gitlab at gitlab.haskell.org
Fri Sep 4 20:25:14 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
89ce7cdf by Sylvain Henry at 2020-09-04T16:24:59-04:00
DynFlags: use Platform in foldRegs*
- - - - -
220ad8d6 by Sylvain Henry at 2020-09-04T16:24:59-04:00
DynFlags: don't pass DynFlags to cmmImplementSwitchPlans
- - - - -
10 changed files:
- compiler/GHC/Cmm/Expr.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Lint.hs
- compiler/GHC/Cmm/Liveness.hs
- compiler/GHC/Cmm/Node.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/ProcPoint.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/Cmm/Switch/Implement.hs
- compiler/GHC/Driver/CodeOutput.hs
Changes:
=====================================
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 #-}
-----------------------------------------------------------------------------
=====================================
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
=====================================
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
=====================================
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) #-}
=====================================
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
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -86,7 +86,7 @@ cpsTop dflags proc =
----------- Implement switches ------------------------------------------
g <- {-# SCC "createSwitchPlans" #-}
- runUniqSM $ cmmImplementSwitchPlans dflags g
+ runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- Proc points -------------------------------------------------
@@ -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
}
=====================================
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
=====================================
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 at .
-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]
=====================================
compiler/GHC/Cmm/Switch/Implement.hs
=====================================
@@ -6,6 +6,7 @@ where
import GHC.Prelude
+import GHC.Driver.Backend
import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.BlockId
@@ -13,7 +14,6 @@ import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Types.Unique.Supply
-import GHC.Driver.Session
import GHC.Utils.Monad (concatMapM)
--
@@ -32,12 +32,12 @@ import GHC.Utils.Monad (concatMapM)
-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
-- code generation.
-cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
-cmmImplementSwitchPlans dflags g
+cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans backend platform g
-- Switch generation done by backend (LLVM/C)
- | backendSupportsSwitch (backend dflags) = return g
+ | backendSupportsSwitch backend = return g
| otherwise = do
- blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)
+ blocks' <- concatMapM (visitSwitches platform) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d6d648866da9e7754859c48235f8009b8c130fd...220ad8d67af345cf3decf82ff26c1e696d21ac93
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d6d648866da9e7754859c48235f8009b8c130fd...220ad8d67af345cf3decf82ff26c1e696d21ac93
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200904/3edc50a7/attachment-0001.html>
More information about the ghc-commits
mailing list