[Git][ghc/ghc][wip/romes/12935] 6 commits: TSAN uniq rename hard
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Tue Jul 2 15:09:03 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
7ca5ab30 by Rodrigo Mesquita at 2024-07-02T14:31:43+01:00
TSAN uniq rename hard
- - - - -
41fb3073 by Rodrigo Mesquita at 2024-07-02T14:31:49+01:00
Revert "TSAN uniq rename hard"
This reverts commit 7ca5ab3036c15f38c6d4cbcb616d415958c6bcda.
- - - - -
1eb0bc67 by Rodrigo Mesquita at 2024-07-02T14:32:56+01:00
improvements to uniqdsm
- - - - -
6d1861ff by Rodrigo Mesquita at 2024-07-02T14:43:12+01:00
UniqDSM ProcPoint
- - - - -
20a34a78 by Rodrigo Mesquita at 2024-07-02T15:25:17+01:00
CmmLayoutStack UniqDet
- - - - -
acfc9c8a by Rodrigo Mesquita at 2024-07-02T16:08:49+01:00
90% of cpsTop UniqDSM
- - - - -
14 changed files:
- compiler/GHC/Cmm/Dataflow.hs
- compiler/GHC/Cmm/Graph.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/ProcPoint.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/Cmm/Switch/Implement.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Monad.hs
Changes:
=====================================
compiler/GHC/Cmm/Dataflow.hs
=====================================
@@ -10,7 +10,7 @@
--
-- This module is a specialised and optimised version of
-- Compiler.Hoopl.Dataflow in the hoopl package. In particular it is
--- specialised to the UniqSM monad.
+-- specialised to the UniqDSM monad.
--
module GHC.Cmm.Dataflow
@@ -33,7 +33,7 @@ where
import GHC.Prelude
import GHC.Cmm
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import Data.Array
import Data.Maybe
@@ -85,14 +85,14 @@ type TransferFun' (n :: Extensibility -> Extensibility -> Type) f =
-- | Function for rewriting and analysis combined. To be used with
-- @rewriteCmm at .
--
--- Currently set to work with @UniqSM@ monad, but we could probably abstract
+-- Currently set to work with @UniqDSM@ monad, but we could probably abstract
-- that away (if we do that, we might want to specialize the fixpoint algorithms
-- to the particular monads through SPECIALIZE).
-type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
+type RewriteFun f = CmmBlock -> FactBase f -> UniqDSM (CmmBlock, FactBase f)
-- | `RewriteFun` abstracted over `n` (the node type)
type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =
- Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)
+ Block n C C -> FactBase f -> UniqDSM (Block n C C, FactBase f)
analyzeCmmBwd, analyzeCmmFwd
:: (NonLocal node)
@@ -167,7 +167,7 @@ rewriteCmmBwd
-> RewriteFun' node f
-> GenCmmGraph node
-> FactBase f
- -> UniqSM (GenCmmGraph node, FactBase f)
+ -> UniqDSM (GenCmmGraph node, FactBase f)
rewriteCmmBwd = rewriteCmm Bwd
rewriteCmm
@@ -177,7 +177,7 @@ rewriteCmm
-> RewriteFun' node f
-> GenCmmGraph node
-> FactBase f
- -> UniqSM (GenCmmGraph node, FactBase f)
+ -> UniqDSM (GenCmmGraph node, FactBase f)
rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
@@ -197,7 +197,7 @@ fixpointRewrite
-> Label
-> LabelMap (Block node C C)
-> FactBase f
- -> UniqSM (LabelMap (Block node C C), FactBase f)
+ -> UniqDSM (LabelMap (Block node C C), FactBase f)
fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
where
-- Sorting the blocks helps to minimize the number of times we need to
@@ -216,7 +216,7 @@ fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
:: IntHeap -- Worklist, i.e., blocks to process
-> LabelMap (Block node C C) -- Rewritten blocks.
-> FactBase f -- Current facts.
- -> UniqSM (LabelMap (Block node C C), FactBase f)
+ -> UniqDSM (LabelMap (Block node C C), FactBase f)
loop todo !blocks1 !fbase1
| Just (index, todo1) <- IntSet.minView todo = do
-- Note that we use the *original* block here. This is important.
@@ -422,10 +422,10 @@ foldNodesBwdOO funOO = go
-- Strict in both accumulated parts.
foldRewriteNodesBwdOO
:: forall f node.
- (node O O -> f -> UniqSM (Block node O O, f))
+ (node O O -> f -> UniqDSM (Block node O O, f))
-> Block node O O
-> f
- -> UniqSM (Block node O O, f)
+ -> UniqDSM (Block node O O, f)
foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
where
go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
=====================================
compiler/GHC/Cmm/Graph.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Data.FastString
import GHC.Types.ForeignCall
import GHC.Data.OrdList
import GHC.Runtime.Heap.Layout (ByteOff)
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Panic
@@ -169,9 +169,9 @@ outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine l (c,s) = unitOL (CgFork l c s)
-- | allocate a fresh label for the entry point
-lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
+lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM CmmGraph
lgraphOfAGraph g = do
- u <- getUniqueM
+ u <- getUniqueDSM
return (labelAGraph (mkBlockId u) g)
-- | use the given BlockId as the label of the entry point
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -68,7 +68,7 @@ mkEmptyContInfoTable info_lbl
cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm logger profile cmms
- = do { detUqSupply <- newIORef 1
+ = do { detUqSupply <- newIORef (initDUniqSupply 'i' 1)
; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
do_one cmm = do
-- NB. strictness fixes a space leak. DO NOT REMOVE.
@@ -80,7 +80,7 @@ cmmToRawCmm logger profile cmms
-- deterministic supplies starting from the same unique in
-- other parts of the Cmm backend
-- See Note [Cmm Local Deterministic Uniques] (TODO)
- let (a, us) = runUniqueDSM 'i' nextUq $
+ let (a, us) = runUniqueDSM nextUq $
concatMapM (mkInfoTable profile) cmm
writeIORef detUqSupply us
return a
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -889,11 +889,7 @@ doSRTs
doSRTs cfg moduleSRTInfo dus procs data_ = do
- -- Use local namespace 'u' here.
- -- See Note [Cmm Local Deterministic Uniques]
- -- in the future, set tag before usign DUniqueSupply
- let runUDSM = runUniqueDSM 'u' dus
-
+ let runUDSM = runUniqueDSM dus
let profile = cmmProfile cfg
-- Ignore the original grouping of decls, and combine all the
=====================================
compiler/GHC/Cmm/LayoutStack.hs
=====================================
@@ -8,7 +8,7 @@ import GHC.Prelude hiding ((<*>))
import GHC.Platform
import GHC.Platform.Profile
-import GHC.StgToCmm.Monad ( newTemp ) -- XXX layering violation
+import GHC.StgToCmm.Monad ( newTempD ) -- XXX layering violation
import GHC.StgToCmm.Utils ( callerSaveVolatileRegs ) -- XXX layering violation
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation
@@ -25,7 +25,7 @@ import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import GHC.Data.Maybe
import GHC.Types.Unique.FM
import GHC.Utils.Misc
@@ -235,7 +235,7 @@ instance Outputable StackMap where
cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph
- -> UniqSM (CmmGraph, LabelMap StackMap)
+ -> UniqDSM (CmmGraph, LabelMap StackMap)
cmmLayoutStack cfg procpoints entry_args
graph@(CmmGraph { g_entry = entry })
= do
@@ -271,7 +271,7 @@ layout :: CmmConfig
-> [CmmBlock] -- [in] blocks
- -> UniqSM
+ -> UniqDSM
( LabelMap StackMap -- [out] stack maps
, ByteOff -- [out] Sp high water mark
, [CmmBlock] -- [out] new blocks
@@ -436,7 +436,7 @@ handleLastNode
-> LabelMap StackMap -> StackMap -> CmmTickScope
-> Block CmmNode O O
-> CmmNode O C
- -> UniqSM
+ -> UniqDSM
( [CmmNode O O] -- nodes to go *before* the Sp adjustment
, ByteOff -- amount to adjust Sp
, CmmNode O C -- new last node
@@ -502,7 +502,7 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
-- proc point, we have to set up the stack to match what the proc
-- point is expecting.
--
- handleBranches :: UniqSM ( [CmmNode O O]
+ handleBranches :: UniqDSM ( [CmmNode O O]
, ByteOff
, CmmNode O C
, [CmmBlock]
@@ -535,7 +535,7 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
, mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
-- For each successor of this block
- handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
+ handleBranch :: BlockId -> UniqDSM (BlockId, BlockId, StackMap, [CmmBlock])
handleBranch l
-- (a) if the successor already has a stackmap, we need to
-- shuffle the current stack to make it look the same.
@@ -570,11 +570,11 @@ handleLastNode cfg procpoints liveness cont_info stackmaps
makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap
-> CmmTickScope -> [CmmNode O O]
- -> UniqSM (Label, [CmmBlock])
+ -> UniqDSM (Label, [CmmBlock])
makeFixupBlock cfg sp0 l stack tscope assigs
| null assigs && sp0 == sm_sp stack = return (l, [])
| otherwise = do
- tmp_lbl <- newBlockId
+ tmp_lbl <- mkBlockId <$> getUniqueDSM {- todo: newBlockId -}
let sp_off = sp0 - sm_sp stack
block = blockJoin (CmmEntry tmp_lbl tscope)
( maybeAddSpAdj cfg sp0 sp_off
@@ -1047,7 +1047,7 @@ insertReloadsAsNeeded
-> LabelMap StackMap
-> BlockId
-> [CmmBlock]
- -> UniqSM [CmmBlock]
+ -> UniqDSM [CmmBlock]
insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =
toBlockList . fst <$>
rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
@@ -1133,15 +1133,15 @@ expecting them (see Note [safe foreign call convention]). Note also
that safe foreign call is replace by an unsafe one in the Cmm graph.
-}
-lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock
lowerSafeForeignCall profile block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
let platform = profilePlatform profile
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
- id <- newTemp (bWord platform)
- new_base <- newTemp (cmmRegType $ baseReg platform)
+ id <- newTempD (bWord platform)
+ new_base <- newTempD (cmmRegType $ baseReg platform)
let (caller_save, caller_load) = callerSaveVolatileRegs platform
save_state_code <- saveThreadState profile
load_state_code <- loadThreadState profile
=====================================
compiler/GHC/Cmm/Opt.hs
=====================================
@@ -22,8 +22,8 @@ import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Utils
import GHC.Cmm
import GHC.Cmm.Config
-
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
+import GHC.Types.Unique
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -664,7 +664,7 @@ cmmMachOpFoldOptM _ _ _ = pure Nothing
intoRegister :: CmmExpr -> CmmType -> Opt CmmExpr
intoRegister e@(CmmReg _) _ = pure e
intoRegister expr ty = do
- u <- getUniqueM
+ u <- getUniqueOpt
let reg = LocalReg u ty
CmmReg (CmmLocal reg) <$ prependNode (CmmAssign (CmmLocal reg) expr)
@@ -754,7 +754,7 @@ generateDivisionBySigned platform _cfg rep n divisor = do
mul2 n
-- Using mul2 for sub-word sizes regresses for signed integers only
| rep == wordWidth platform = do
- (r1, r2, r3) <- (,,) <$> getUniqueM <*> getUniqueM <*> getUniqueM
+ (r1, r2, r3) <- (,,) <$> getUniqueOpt <*> getUniqueOpt <*> getUniqueOpt
let rg1 = LocalReg r1 resRep
resReg = LocalReg r2 resRep
rg3 = LocalReg r3 resRep
@@ -845,7 +845,7 @@ generateDivisionByUnsigned platform cfg rep n divisor = do
-- generate the multiply with the magic number
mul2 n
| rep == wordWidth platform || (cmmAllowMul2 cfg && needsAdd) = do
- (r1, r2) <- (,) <$> getUniqueM <*> getUniqueM
+ (r1, r2) <- (,) <$> getUniqueOpt <*> getUniqueOpt
let rg1 = LocalReg r1 resRep
resReg = LocalReg r2 resRep
res <- CmmReg (CmmLocal resReg) <$ prependNode (CmmUnsafeForeignCall (PrimTarget (MO_U_Mul2 rep)) [resReg, rg1] [n, CmmLit $ CmmInt magic rep])
@@ -897,16 +897,16 @@ divisionMagicU rep doPreShift divisor = (toInteger zeros, magic, needsAdd, toInt
-- -----------------------------------------------------------------------------
-- Opt monad
-newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqSM ([CmmNode O O], a) }
+newtype Opt a = OptI { runOptI :: CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a) }
-- | Pattern synonym for 'Opt', as described in Note [The one-shot state
-- monad trick].
-pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqSM ([CmmNode O O], a)) -> Opt a
+pattern Opt :: (CmmConfig -> [CmmNode O O] -> UniqDSM ([CmmNode O O], a)) -> Opt a
pattern Opt f <- OptI f
where Opt f = OptI . oneShot $ \cfg -> oneShot $ \out -> f cfg out
{-# COMPLETE Opt #-}
-runOpt :: CmmConfig -> Opt a -> UniqSM ([CmmNode O O], a)
+runOpt :: CmmConfig -> Opt a -> UniqDSM ([CmmNode O O], a)
runOpt cf (Opt g) = g cf []
getConfig :: Opt CmmConfig
@@ -926,10 +926,8 @@ instance Monad Opt where
(ys, a) <- g cf xs
runOptI (f a) cf ys
-instance MonadUnique Opt where
- getUniqueSupplyM = Opt $ \_ xs -> (xs,) <$> getUniqueSupplyM
- getUniqueM = Opt $ \_ xs -> (xs,) <$> getUniqueM
- getUniquesM = Opt $ \_ xs -> (xs,) <$> getUniquesM
+getUniqueOpt :: Opt Unique
+getUniqueOpt = Opt $ \_ xs -> (xs,) <$> getUniqueDSM
mapForeignTargetOpt :: (CmmExpr -> Opt CmmExpr) -> ForeignTarget -> Opt ForeignTarget
mapForeignTargetOpt exp (ForeignTarget e c) = flip ForeignTarget c <$> exp e
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -25,12 +25,13 @@ import GHC.Types.Unique.Supply
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
-import GHC.Utils.Misc ( partitionWithM )
+import GHC.Utils.Misc ( partitionWith )
import GHC.Platform
import Control.Monad
import GHC.Cmm.UniqueRenamer
+import GHC.Utils.Monad (mapAccumLM)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
@@ -47,12 +48,13 @@ cmmPipeline
-> CmmGroup -- Input C-- with Procedures
-> IO (ModuleSRTInfo, DUniqSupply, CmmGroupSRTs) -- Output CPS transformed C--
-cmmPipeline logger cmm_config srtInfo dus prog = do
+cmmPipeline logger cmm_config srtInfo dus0 prog = do
let forceRes (info, us, group) = info `seq` us `seq` foldr seq () group
let platform = cmmPlatform cmm_config
withTimingSilent logger (text "Cmm pipeline") forceRes $ do
- (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config {-TODO: dus argument too -}) prog
- (srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus procs data_
+ (dus1, prog') <- {-# SCC "tops" #-} mapAccumLM (cpsTop logger platform cmm_config) dus0 prog
+ let (procs, data_) = partitionWith id prog'
+ (srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus1 procs data_
dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
return (srtInfo, dus, cmms)
@@ -65,12 +67,12 @@ cmmPipeline logger cmm_config srtInfo dus prog = do
-- [SRTs].
--
-- - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing
-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
-cpsTop logger platform _ (CmmData section statics) = do
+cpsTop :: Logger -> Platform -> CmmConfig -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
+cpsTop logger platform _ dus (CmmData section statics) = do
dumpWith logger Opt_D_dump_cmm_verbose "Pre CPS Data" FormatCMM (pdoc platform (CmmData section statics :: CmmDataDecl))
dumpWith logger Opt_D_dump_cmm_verbose "Post CPS Data" FormatCMM (pdoc platform (cafAnalData platform statics))
- return (Right (cafAnalData platform statics, CmmData section statics))
-cpsTop logger platform cfg proc =
+ return (dus, Right (cafAnalData platform statics, CmmData section statics))
+cpsTop logger platform cfg dus proc =
do
----------- Control-flow optimisations ----------------------------------
@@ -94,16 +96,21 @@ cpsTop logger platform cfg proc =
-- elimCommonBlocks
----------- Implement switches ------------------------------------------
- g <- if cmmDoCmmSwitchPlans cfg
+ (g, dus) <- if cmmDoCmmSwitchPlans cfg
then {-# SCC "createSwitchPlans" #-}
- runUniqSM $ cmmImplementSwitchPlans platform g
- else pure g
+ pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g
+ else pure (g, dus)
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- ThreadSanitizer instrumentation -----------------------------
g <- {-# SCC "annotateTSAN" #-}
if cmmOptThreadSanitizer cfg
- then runUniqSM $ annotateTSAN platform g
+ then do
+ -- romes: hard to support deterministic here without changing too
+ -- much in graph, maybe we can skip it.
+ us <- mkSplitUniqSupply 'u'
+ return $ initUs_ us $
+ annotateTSAN platform g
else return g
dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g
@@ -111,30 +118,30 @@ cpsTop logger platform cfg proc =
let
call_pps :: ProcPointSet -- LabelMap
call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
- proc_points <-
+ (proc_points, dus) <-
if splitting_proc_points
then do
- pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
- minimalProcPointSet platform call_pps g
+ let (pp, dus) = {-# SCC "minimalProcPointSet" #-} runUniqueDSM dus $
+ minimalProcPointSet platform call_pps g
dumpWith logger Opt_D_dump_cmm_proc "Proc points"
FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
- return pp
+ return (pp, dus)
else
- return call_pps
+ return (call_pps, dus)
----------- Layout the stack and manifest Sp ----------------------------
- (g, stackmaps) <-
- {-# SCC "layoutStack" #-}
- if do_layout
- then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g
- else return (g, mapEmpty)
+ ((g, stackmaps), dus) <- pure $
+ {-# SCC "layoutStack" #-}
+ if do_layout
+ then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g
+ else ((g, mapEmpty), dus)
dump Opt_D_dump_cmm_sp "Layout Stack" g
----------- Sink and inline assignments --------------------------------
- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
+ (g, dus) <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
if cmmOptSink cfg
- then runUniqSM $ cmmSink cfg g
- else return g
+ then pure $ runUniqueDSM dus $ cmmSink cfg g
+ else return (g, dus)
dump Opt_D_dump_cmm_sink "Sink assignments" g
@@ -142,21 +149,21 @@ cpsTop logger platform cfg proc =
let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
- g <- if splitting_proc_points
+ (g, dus) <- if splitting_proc_points
then do
------------- Split into separate procedures -----------------------
let pp_map = {-# SCC "procPointAnalysis" #-}
procPointAnalysis proc_points g
dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"
FormatCMM (ppr pp_map)
- g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+ (g, dus) <- {-# SCC "splitAtProcPoints" #-} pure $ runUniqueDSM dus $
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
+ return (g, dus)
else
-- attach info tables to return points
- return $ [attachContInfoTables call_pps (CmmProc h l v g)]
+ return ([attachContInfoTables call_pps (CmmProc h l v g)], dus)
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
@@ -172,7 +179,7 @@ cpsTop logger platform cfg proc =
-- See Note [unreachable blocks]
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations (2)" g
- return (Left (cafEnv, g))
+ return (dus, Left (cafEnv, g))
where dump = dumpGraph logger platform (cmmDoLinting cfg)
@@ -356,12 +363,6 @@ generator later.
-}
--- ROMESTODO: MAKE THIS DETERMINISTIC!!!!!!
-runUniqSM :: UniqSM a -> IO a
-runUniqSM m = do
- us <- mkSplitUniqSupply 'u'
- return (initUs_ us m)
-
dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph logger platform do_linting flag name g = do
when do_linting $ do_lint g
=====================================
compiler/GHC/Cmm/ProcPoint.hs
=====================================
@@ -24,7 +24,7 @@ import Control.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Platform
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Graph
@@ -185,14 +185,14 @@ callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
_ -> set
minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
- -> UniqSM ProcPointSet
+ -> UniqDSM ProcPointSet
-- Given the set of successors of calls (which must be proc-points)
-- figure out the minimal set of necessary proc-points
minimalProcPointSet platform callProcPoints g
= extendPPSet platform g (revPostorder g) callProcPoints
extendPPSet
- :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+ :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqDSM ProcPointSet
extendPPSet platform g blocks procPoints =
let env = procPointAnalysis procPoints g
add pps block = let id = entryLabel block
@@ -236,7 +236,7 @@ extendPPSet platform g blocks procPoints =
-- ToDo: use the _ret naming convention that the old code generator
-- used. -- EZY
splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl
- -> UniqSM [CmmDecl]
+ -> UniqDSM [CmmDecl]
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
-- Build a map from procpoints to the blocks they reach
@@ -286,9 +286,9 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
-- and replace branches to procpoints with branches to the jump-off blocks
let add_jump_block :: (LabelMap Label, [CmmBlock])
-> (Label, CLabel)
- -> UniqSM (LabelMap Label, [CmmBlock])
+ -> UniqDSM (LabelMap Label, [CmmBlock])
add_jump_block (env, bs) (pp, l) = do
- bid <- liftM mkBlockId getUniqueM
+ bid <- liftM mkBlockId getUniqueDSM
let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
live = ppLiveness pp
jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
@@ -317,7 +317,7 @@ splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
CmmSwitch _ ids -> foldr add_if_pp rst $ switchTargetsToList ids
_ -> rst
- let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
+ let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqDSM (LabelMap CmmGraph)
add_jumps newGraphEnv (ppId, blockEnv) = do
-- find which procpoints we currently branch to
let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv
=====================================
compiler/GHC/Cmm/Sink.hs
=====================================
@@ -20,7 +20,7 @@ import GHC.Platform.Regs
import GHC.Platform
import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import GHC.Cmm.Config
import Data.List (partition)
@@ -152,7 +152,7 @@ type Assignments = [Assignment]
-- y = e2
-- x = e1
-cmmSink :: CmmConfig -> CmmGraph -> UniqSM CmmGraph
+cmmSink :: CmmConfig -> CmmGraph -> UniqDSM CmmGraph
cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
where
platform = cmmPlatform cfg
@@ -163,7 +163,7 @@ cmmSink cfg graph = ofBlockList (g_entry graph) <$> sink mapEmpty blocks
join_pts = findJoinPoints blocks
- sink :: LabelMap Assignments -> [CmmBlock] -> UniqSM [CmmBlock]
+ sink :: LabelMap Assignments -> [CmmBlock] -> UniqDSM [CmmBlock]
sink _ [] = pure []
sink sunk (b:bs) = do
-- Now sink and inline in this block
@@ -312,7 +312,7 @@ walk :: CmmConfig
-- Earlier assignments may refer
-- to later ones.
- -> UniqSM ( Block CmmNode O O -- The new block
+ -> UniqDSM ( Block CmmNode O O -- The new block
, Assignments -- Assignments to sink further
)
@@ -598,7 +598,7 @@ improveConditional other = other
-- Now we can go ahead and inline x.
--
-- For now we do nothing, because this would require putting
--- everything inside UniqSM.
+-- everything inside UniqDSM.
--
-- One more variant of this (#7366):
--
=====================================
compiler/GHC/Cmm/Switch/Implement.hs
=====================================
@@ -12,8 +12,8 @@ import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
-import GHC.Types.Unique.Supply
import GHC.Utils.Monad (concatMapM)
+import GHC.Cmm.UniqueRenamer
--
-- This module replaces Switch statements as generated by the Stg -> Cmm
@@ -31,14 +31,14 @@ import GHC.Utils.Monad (concatMapM)
-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
-- code generation.
-cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqDSM CmmGraph
cmmImplementSwitchPlans platform g =
-- Switch generation done by backend (LLVM/C)
do
blocks' <- concatMapM (visitSwitches platform) (toBlockList g)
return $ ofBlockList (g_entry g) blocks'
-visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches :: Platform -> CmmBlock -> UniqDSM [CmmBlock]
visitSwitches platform block
| (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block
= do
@@ -69,15 +69,15 @@ visitSwitches platform block
-- This happened in parts of the handwritten RTS Cmm code. See also #16933
-- See Note [Floating switch expressions]
-floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
+floatSwitchExpr :: Platform -> CmmExpr -> UniqDSM (Block CmmNode O O, CmmExpr)
floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
floatSwitchExpr platform expr = do
- (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM
+ (assign, expr') <- cmmMkAssign platform expr <$> getUniqueDSM
return (BMiddle assign, expr')
-- Implementing a switch plan (returning a tail block)
-implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqDSM (Block CmmNode O C, [CmmBlock])
implementSwitchPlan platform scope expr = go
where
width = typeWidth $ cmmExprType platform expr
@@ -111,7 +111,7 @@ implementSwitchPlan platform scope expr = go
= return (l, [])
go' p
= do
- bid <- mkBlockId `fmap` getUniqueM
+ bid <- mkBlockId `fmap` getUniqueDSM
(last, newBlocks) <- go p
let block = CmmEntry bid scope `blockJoinHead` last
return (bid, block: newBlocks)
=====================================
compiler/GHC/Cmm/UniqueRenamer.hs
=====================================
@@ -1,16 +1,19 @@
-{-# LANGUAGE LambdaCase, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces, TypeFamilies #-}
+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
module GHC.Cmm.UniqueRenamer
( detRenameUniques
, UniqDSM, runUniqueDSM
- , DUniqSupply, getUniqueDSM
+ , DUniqSupply, getUniqueDSM, takeUniqueFromDSupply, initDUniqSupply, newTagDUniqSupply
+ , MonadGetUnique(..)
-- Careful! Not for general use!
- , DetUniqFM, emptyDetUFM)
+ , DetUniqFM, emptyDetUFM
+ )
where
import Data.Bits
import Prelude
import Control.Monad.Trans.State
+import Control.Monad.Fix
import GHC.Word
import GHC.Cmm
import GHC.Cmm.CLabel
@@ -24,6 +27,7 @@ import GHC.Types.Unique.FM
import GHC.Utils.Outputable as Outputable
import Data.Tuple (swap)
import GHC.Types.Id
+import qualified GHC.Types.Unique.Supply as USM
{-
--------------------------------------------------------------------------------
@@ -70,7 +74,7 @@ renameDetUniq uq = do
Nothing -> do
new_w <- gets supply -- New deterministic unique in this `DetRnM`
let (tag, _) = unpkUnique uq
- det_uniq = mkUnique tag new_w
+ det_uniq = mkUnique 'Q' new_w
modify' (\DetUniqFM{mapping, supply} ->
-- Update supply and mapping
DetUniqFM
@@ -284,7 +288,7 @@ panicMapKeysNotInjective _ _ = error "this should be impossible because the func
-- there, but without the unboxing it feels? Maybe not, since we carry the
-- mappings too.
-type DUniqSupply = Word64 -- supply uniques iteratively
+newtype DUniqSupply = DUS Word64 -- supply uniques iteratively
type DUniqResult result = (# result, DUniqSupply #)
pattern DUniqResult :: a -> b -> (# a, b #)
@@ -293,35 +297,58 @@ pattern DUniqResult x y = (# x, y #)
-- | A monad which just gives the ability to obtain 'Unique's deterministically.
-- There's no splitting.
-newtype UniqDSM result = UDSM { unUDSM :: Word64 {- tag -} -> DUniqSupply -> DUniqResult result }
+newtype UniqDSM result = UDSM { unUDSM :: DUniqSupply -> DUniqResult result }
deriving Functor
instance Monad UniqDSM where
- (>>=) (UDSM f) cont = UDSM $ \tag us0 -> case f tag us0 of
- DUniqResult result us1 -> unUDSM (cont result) tag us1
+ (>>=) (UDSM f) cont = UDSM $ \us0 -> case f us0 of
+ DUniqResult result us1 -> unUDSM (cont result) us1
(>>) = (*>)
{-# INLINE (>>=) #-}
{-# INLINE (>>) #-}
instance Applicative UniqDSM where
- pure result = UDSM (\_tag us -> DUniqResult result us)
- (UDSM f) <*> (UDSM x) = UDSM $ \tag us0 -> case f tag us0 of
- DUniqResult ff us1 -> case x tag us1 of
+ pure result = UDSM (DUniqResult result)
+ (UDSM f) <*> (UDSM x) = UDSM $ \us0 -> case f us0 of
+ DUniqResult ff us1 -> case x us1 of
DUniqResult xx us2 -> DUniqResult (ff xx) us2
- (*>) (UDSM expr) (UDSM cont) = UDSM $ \tag us0 -> case expr tag us0 of
- DUniqResult _ us1 -> cont tag us1
+ (*>) (UDSM expr) (UDSM cont) = UDSM $ \us0 -> case expr us0 of
+ DUniqResult _ us1 -> cont us1
{-# INLINE pure #-}
{-# INLINE (*>) #-}
+instance MonadFix UniqDSM where
+ mfix m = UDSM (\us0 -> let (r,us1) = runUniqueDSM us0 (m r) in DUniqResult r us1)
+
getUniqueDSM :: UniqDSM Unique
-getUniqueDSM = UDSM (\tag us0 -> DUniqResult (mkUniqueGrimily $ tag .|. us0) (us0+1))
-
-runUniqueDSM :: Char {- tag -} -> DUniqSupply {- first unique -}
- -> UniqDSM a -> (a, DUniqSupply)
-runUniqueDSM c firstUniq (UDSM f) =
- let !tag = mkTag c
- in case f tag firstUniq of
- DUniqResult uq us -> (uq, us)
+getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily us0) (DUS $ us0+1))
+
+takeUniqueFromDSupply :: DUniqSupply -> (Unique, DUniqSupply)
+takeUniqueFromDSupply d =
+ case unUDSM getUniqueDSM d of
+ DUniqResult x y -> (x, y)
+
+initDUniqSupply :: Char -> Word64 -> DUniqSupply
+initDUniqSupply c firstUniq =
+ let !tag = mkTag 'Q' {- TODO: c -}
+ in DUS (tag .|. firstUniq)
+
+newTagDUniqSupply :: Char -> DUniqSupply -> DUniqSupply
+newTagDUniqSupply c (DUS w) = DUS $ getKey $ newTagUnique (mkUniqueGrimily w) c
+
+runUniqueDSM :: DUniqSupply -> UniqDSM a -> (a, DUniqSupply)
+runUniqueDSM ds (UDSM f) =
+ case f ds of
+ DUniqResult uq us -> (uq, us)
+
+class Monad m => MonadGetUnique m where
+ getUniqueM :: m Unique
+
+instance MonadGetUnique UniqDSM where
+ getUniqueM = getUniqueDSM
+
+instance MonadGetUnique USM.UniqSM where
+ getUniqueM = USM.getUniqueM
{-
Note [Cmm Local Deterministic Uniques]
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2098,7 +2098,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
cmmgroup <- concat . snd <$>
mapAccumLM (\(msrt0, dus0) cmm -> do
(msrt1, dus1, cmm') <- cmmPipeline logger cmm_config msrt0 dus0 [cmm]
- return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, 1) cmm
+ return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 1) cmm
unless (null cmmgroup) $
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
@@ -2198,7 +2198,7 @@ doCodeGen hsc_env this_mod denv data_tycons
pipeline_stream = do
((mod_srt_info, ipes, ipe_stats, dus), lf_infos) <-
{-# SCC "cmmPipeline" #-}
- Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty, 1) ppr_stream1
+ Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty, initDUniqSupply 'u' 1) ppr_stream1
let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)
cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats, dus)
return cmmCgInfos
=====================================
compiler/GHC/StgToCmm/Foreign.hs
=====================================
@@ -48,7 +48,7 @@ import GHC.Runtime.Heap.Layout
import GHC.Types.ForeignCall
import GHC.Data.Maybe
import GHC.Utils.Panic
-import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer
import GHC.Types.Basic
import GHC.Unit.Types
@@ -354,7 +354,7 @@ emitSaveThreadState = do
emit code
-- | Produce code to save the current thread state to @CurrentTSO@
-saveThreadState :: MonadUnique m => Profile -> m CmmAGraph
+saveThreadState :: MonadGetUnique m => Profile -> m CmmAGraph
saveThreadState profile = do
let platform = profilePlatform profile
tso <- newTemp (gcWord platform)
@@ -493,7 +493,7 @@ Closing the nursery corresponds to the following code:
cn->free = Hp + WDS(1);
@
-}
-closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
+closeNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph
closeNursery profile tso = do
let tsoreg = CmmLocal tso
platform = profilePlatform profile
@@ -526,7 +526,7 @@ emitLoadThreadState = do
emit code
-- | Produce code to load the current thread state from @CurrentTSO@
-loadThreadState :: MonadUnique m => Profile -> m CmmAGraph
+loadThreadState :: MonadGetUnique m => Profile -> m CmmAGraph
loadThreadState profile = do
let platform = profilePlatform profile
tso <- newTemp (gcWord platform)
@@ -591,7 +591,7 @@ Opening the nursery corresponds to the following code:
HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
@
-}
-openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
+openNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph
openNursery profile tso = do
let tsoreg = CmmLocal tso
platform = profilePlatform profile
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.StgToCmm.Monad (
emitOutOfLine, emitAssign, emitStore, emitStore',
emitComment, emitTick, emitUnwind,
- newTemp,
+ newTemp, newTempD,
getCmm, aGraphToGraph, getPlatform, getProfile,
getCodeR, getCode, getCodeScoped, getHeapUsage,
@@ -85,6 +85,8 @@ import GHC.Data.OrdList
import GHC.Types.Basic( ConTagZ )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
+import GHC.Cmm.UniqueRenamer ( UniqDSM, getUniqueDSM, MonadGetUnique )
+import qualified GHC.Cmm.UniqueRenamer as UR
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -170,6 +172,9 @@ instance MonadUnique FCode where
let (u, us') = takeUniqFromSupply (cgs_uniqs st)
in (u, st { cgs_uniqs = us' })
+instance MonadGetUnique FCode where
+ getUniqueM = GHC.Types.Unique.Supply.getUniqueM
+
initC :: IO CgState
initC = do { uniqs <- mkSplitUniqSupply 'c'
; return (initCgState uniqs) }
@@ -450,10 +455,14 @@ newUnique = do
setState $ state { cgs_uniqs = us' }
return u
-newTemp :: MonadUnique m => CmmType -> m LocalReg
-newTemp rep = do { uniq <- getUniqueM
+newTemp :: MonadGetUnique m => CmmType -> m LocalReg
+newTemp rep = do { uniq <- UR.getUniqueM
; return (LocalReg uniq rep) }
+newTempD :: CmmType -> UniqDSM LocalReg
+newTempD rep = do { uniq <- getUniqueDSM
+ ; return (LocalReg uniq rep) }
+
------------------
initFCodeState :: Platform -> FCodeState
initFCodeState p =
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cf90ba5694710b27b102837aa5ed2e0a6bd5640...acfc9c8a5faccd828c2aa06888856d9a4237009b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7cf90ba5694710b27b102837aa5ed2e0a6bd5640...acfc9c8a5faccd828c2aa06888856d9a4237009b
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/20240702/ce381957/attachment-0001.html>
More information about the ghc-commits
mailing list