[Git][ghc/ghc][wip/romes/12935] 4 commits: DCmmGroup vs CmmGroup or: Deterministic Info Tables
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Sep 5 09:22:44 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
b756c6b7 by Rodrigo Mesquita at 2024-09-05T10:22:10+01:00
DCmmGroup vs CmmGroup or: Deterministic Info Tables
See Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] and Note [Object determinism]
cmm: Back LabelMap with UDFM
Use a deterministic unique map to back the implementation of `LabelMap`.
This is necessary towards the goal of object code determinism in #12935.
Our intended solution requires renaming uniques in a deterministic
order (which will be the order in which they were created), but storing
them label map makes us lose this order. Backing it with a UDFM fixes
this issue.
Introduce back LabelMap non deterministic
Use NonDeterministic Label map in multiple passes
(TODO: More could be available. Look through Det LabelMap uses again)
Use NonDet for CFG
More NonDet
More explicit
Introduce DCmmDecl, start
Removing more maps
- - - - -
776543ea by Rodrigo Mesquita at 2024-09-05T10:22:22+01:00
Don't print unique in pprFullName
This unique was leaking as part of the profiling description in info tables when profiling was enabled
- - - - -
879263c1 by Rodrigo Mesquita at 2024-09-05T10:22:22+01:00
distinct-constructor-tables determinism
- - - - -
f446aa3c by Rodrigo Mesquita at 2024-09-05T10:22:22+01:00
Rename deterministically CmmGroups in generateCgIPEStub
- - - - -
20 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/Dataflow/Graph.hs
- compiler/GHC/Cmm/Graph.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/ThreadSanitizer.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/CgUtils.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Types/IPE.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -12,22 +12,28 @@
module GHC.Cmm (
-- * Cmm top-level datatypes
+ DCmmGroup,
CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
- CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
- CmmDataDecl, cmmDataDeclCmmDecl,
- CmmGraph, GenCmmGraph(..),
+ CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+ CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph,
+ CmmGraph, GenCmmGraph, GenGenCmmGraph(..),
toBlockMap, revPostorder, toBlockList,
CmmBlock, RawCmmDecl,
Section(..), SectionType(..),
GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
SectionProtection(..), sectionProtection,
+ DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph,
+
-- ** Blocks containing lists
GenBasicBlock(..), blockId,
ListGraph(..), pprBBlock,
-- * Info Tables
- CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+ GenCmmTopInfo(..)
+ , DCmmTopInfo
+ , CmmTopInfo
+ , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD,
ClosureTypeInfo(..),
ProfilingInfo(..), ConstrDescription,
@@ -74,6 +80,8 @@ import qualified Data.ByteString as BS
type CmmProgram = [CmmGroup]
type GenCmmGroup d h g = [GenCmmDecl d h g]
+-- | Cmm group after STG generation
+type DCmmGroup = GenCmmGroup CmmStatics DCmmTopInfo DCmmGraph
-- | Cmm group before SRT generation
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
-- | Cmm group with SRTs
@@ -117,6 +125,7 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
=> OutputableP Platform (GenCmmDecl d info i) where
pdoc = pprTop
+type DCmmDecl = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
type CmmDataDecl = GenCmmDataDecl CmmStatics
@@ -139,7 +148,11 @@ type RawCmmDecl
-----------------------------------------------------------------------------
type CmmGraph = GenCmmGraph CmmNode
-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type DCmmGraph = GenGenCmmGraph DWrap CmmNode
+
+type GenCmmGraph n = GenGenCmmGraph LabelMap n
+
+data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C }
type CmmBlock = Block CmmNode C C
instance OutputableP Platform CmmGraph where
@@ -171,8 +184,16 @@ toBlockList g = mapElems $ toBlockMap g
-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains
-- the extra info (beyond the executable code) that belongs to that CmmDecl.
-data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
- , stack_info :: CmmStackInfo }
+data GenCmmTopInfo f = TopInfo { info_tbls :: f CmmInfoTable
+ , stack_info :: CmmStackInfo }
+
+newtype DWrap a = DWrap [(BlockId, a)]
+
+unDeterm :: DWrap a -> [(BlockId, a)]
+unDeterm (DWrap f) = f
+
+type DCmmTopInfo = GenCmmTopInfo DWrap
+type CmmTopInfo = GenCmmTopInfo LabelMap
instance OutputableP Platform CmmTopInfo where
pdoc = pprTopInfo
@@ -182,7 +203,12 @@ pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
vcat [text "info_tbls: " <> pdoc platform info_tbl,
text "stack_info: " <> ppr stack_info]
-topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
+topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of
+ DWrap xs -> lookup (g_entry g) xs
+topInfoTableD _ = Nothing
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
@@ -237,6 +263,7 @@ data ProfilingInfo
= NoProfilingInfo
| ProfilingInfo ByteString ByteString -- closure_type, closure_desc
deriving (Eq, Ord)
+
-----------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
@@ -328,6 +355,58 @@ instance OutputableP Platform (GenCmmStatics a) where
type CmmStatics = GenCmmStatics 'False
type RawCmmStatics = GenCmmStatics 'True
+{-
+-----------------------------------------------------------------------------
+-- Deterministic Cmm / Info Tables
+-----------------------------------------------------------------------------
+
+Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consulting Note [Object determinism] one will learn that in order to produce
+deterministic objects just after cmm is produced we perform a renaming pass which
+provides fresh uniques for all unique-able things in the input Cmm.
+
+After this point, we use a deterministic unique supply (an incrementing counter)
+so any resulting labels which make their way into object code have a deterministic name.
+
+A key assumption to this process is that the input is deterministic modulo the uniques
+and the order that bindings appear in the definitions is the same.
+
+CmmGroup uses LabelMap in two places:
+
+* In CmmProc for info tables
+* In CmmGraph for the blocks of the graph
+
+LabelMap is not a deterministic strucutre, so traversing a LabelMap can process
+elements in different order (depending on the given uniques).
+
+Therefore before we do the renaming we need to use a deterministic strucutre, one
+which we can traverse in a guaranteed order. A list does the job perfectly.
+
+Once the renaming happens it is converted back into a LabelMap, which is now deterministic
+due to the uniques being generated and assigned in a deterministic manner.
+
+-}
+
+-- Converting out of deterministic Cmm
+
+removeDeterm :: DCmmGroup -> CmmGroup
+removeDeterm = map removeDetermDecl
+
+removeDetermDecl :: DCmmDecl -> CmmDecl
+removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g)
+removeDetermDecl (CmmData a b) = CmmData a b
+
+removeDetermTop :: DCmmTopInfo -> CmmTopInfo
+removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b
+
+removeDetermGraph :: DCmmGraph -> CmmGraph
+removeDetermGraph (CmmGraph x y) =
+ let y' = case y of
+ GMany a (DWrap b) c -> GMany a (mapFromList b) c
+ in CmmGraph x y'
+
-- -----------------------------------------------------------------------------
-- Basic blocks consisting of lists
=====================================
compiler/GHC/Cmm/Dataflow/Graph.hs
=====================================
@@ -26,10 +26,10 @@ import GHC.Cmm.Dataflow.Block
import Data.Kind
-- | A (possibly empty) collection of closed/closed blocks
-type Body n = LabelMap (Block n C C)
+type Body s n = Body' s Block n
-- | @Body@ abstracted over @block@
-type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)
+type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C)
-------------------------------
-- | Gives access to the anchor points for
@@ -46,13 +46,13 @@ instance NonLocal n => NonLocal (Block n) where
successors (BlockCC _ _ n) = successors n
-emptyBody :: Body' block n
+emptyBody :: Body' LabelMap block n
emptyBody = mapEmpty
-bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList :: Body' LabelMap block n -> [(Label,block n C C)]
bodyList body = mapToList body
-bodyToBlockList :: Body n -> [Block n C C]
+bodyToBlockList :: Body LabelMap n -> [Block n C C]
bodyToBlockList body = mapElems body
addBlock
@@ -72,18 +72,18 @@ addBlock block body = mapAlter add lbl body
-- O/C, C/O, C/C). A graph open at the entry has a single,
-- distinguished, anonymous entry point; if a graph is closed at the
-- entry, its entry point(s) are supplied by a context.
-type Graph = Graph' Block
+type Graph = Graph' LabelMap Block
-- | @Graph'@ is abstracted over the block type, so that we can build
-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
-- needs this).
-data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
- GNil :: Graph' block n O O
- GUnit :: block n O O -> Graph' block n O O
+data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where
+ GNil :: Graph' s block n O O
+ GUnit :: block n O O -> Graph' s block n O O
GMany :: MaybeO e (block n O C)
- -> Body' block n
+ -> Body' s block n
-> MaybeO x (block n C O)
- -> Graph' block n e x
+ -> Graph' s block n e x
-- -----------------------------------------------------------------------------
@@ -91,26 +91,27 @@ data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
-- | Maps over all nodes in a graph.
mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
-mapGraph f = mapGraphBlocks (mapBlock f)
+mapGraph f = mapGraphBlocks mapMap (mapBlock f)
-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
-- nodes, or both. It lifts a polymorphic block transform into a polymorphic
-- graph transform. When the block representation stabilizes, a similar
-- function should be provided for blocks.
-mapGraphBlocks :: forall block n block' n' e x .
- (forall e x . block n e x -> block' n' e x)
- -> (Graph' block n e x -> Graph' block' n' e x)
+mapGraphBlocks :: forall s block n block' n' e x .
+ (forall a b . (a -> b) -> s a -> s b)
+ -> (forall e x . block n e x -> block' n' e x)
+ -> (Graph' s block n e x -> Graph' s block' n' e x)
-mapGraphBlocks f = map
- where map :: Graph' block n e x -> Graph' block' n' e x
+mapGraphBlocks f g = map
+ where map :: Graph' s block n e x -> Graph' s block' n' e x
map GNil = GNil
- map (GUnit b) = GUnit (f b)
- map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+ map (GUnit b) = GUnit (g b)
+ map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x)
-- -----------------------------------------------------------------------------
-- Extracting Labels from graphs
-labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x
-> LabelSet
labelsDefined GNil = setEmpty
labelsDefined (GUnit{}) = setEmpty
=====================================
compiler/GHC/Cmm/Graph.hs
=====================================
@@ -73,12 +73,12 @@ data CgStmt
| CgLast (CmmNode O C)
| CgFork BlockId CmmAGraph CmmTickScope
-flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph
flattenCmmAGraph id (stmts_t, tscope) =
CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO }
where
- body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
+ body = DWrap [(entryLabel b, b) | b <- flatten id stmts_t tscope [] ]
--
-- flatten: given an entry label and a CmmAGraph, make a list of blocks.
@@ -169,13 +169,13 @@ outOfLine :: BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine l (c,s) = unitOL (CgFork l c s)
-- | allocate a fresh label for the entry point
-lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM CmmGraph
+lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM DCmmGraph
lgraphOfAGraph g = do
u <- getUniqueDSM
return (labelAGraph (mkBlockId u) g)
-- | use the given BlockId as the label of the entry point
-labelAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
+labelAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph
labelAGraph lbl ag = flattenCmmAGraph lbl ag
---------- No-ops
=====================================
compiler/GHC/Cmm/LayoutStack.hs
=====================================
@@ -282,12 +282,18 @@ layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high bl
where
(updfr, cont_info) = collectContInfo blocks
- init_stackmap = mapSingleton entry StackMap{ sm_sp = entry_args
- , sm_args = entry_args
- , sm_ret_off = updfr
- , sm_regs = emptyUFM
- }
-
+ init_stackmap = mapSingleton entry
+ StackMap{ sm_sp = entry_args
+ , sm_args = entry_args
+ , sm_ret_off = updfr
+ , sm_regs = emptyUFM
+ }
+
+ go :: [Block CmmNode C C]
+ -> LabelMap StackMap
+ -> StackLoc
+ -> [CmmBlock]
+ -> UniqDSM (LabelMap StackMap, StackLoc, [CmmBlock])
go [] acc_stackmaps acc_hwm acc_blocks
= return (acc_stackmaps, acc_hwm, acc_blocks)
@@ -1180,7 +1186,7 @@ lowerSafeForeignCall profile block
copyout <*>
mkLast jump, tscp)
- case toBlockList graph' of
+ case toBlockList (removeDetermGraph graph') of
[one] -> let (_, middle', last) = blockSplit one
in return (blockJoin entry (middle `blockAppend` middle') last)
_ -> panic "lowerSafeForeignCall0"
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1575,7 +1575,7 @@ parseCmmFile :: CmmParserConfig
-> Module
-> HomeUnit
-> FilePath
- -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))
+ -> IO (Messages PsMessage, Messages PsMessage, Maybe (DCmmGroup, [InfoProvEnt]))
parseCmmFile cmmpConfig this_mod home_unit filename = do
buf <- hGetStringBuffer filename
let
@@ -1595,7 +1595,7 @@ parseCmmFile cmmpConfig this_mod home_unit filename = do
((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()
-- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
let used_info
- | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)
+ | do_ipe = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTableD cmm)
| otherwise = []
where
do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig
=====================================
compiler/GHC/Cmm/ThreadSanitizer.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.Unique
import GHC.Types.Unique.Supply
+import GHC.Cmm.Dataflow.Label
import Data.Maybe (fromMaybe)
@@ -29,7 +30,7 @@ data Env = Env { platform :: Platform
annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph
annotateTSAN platform graph = do
env <- Env platform <$> getUniqueSupplyM
- return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph
+ return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph
mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')
-> Block n e x -> Block n e x
=====================================
compiler/GHC/CmmToAsm/Reg/Liveness.hs
=====================================
@@ -14,7 +14,7 @@
module GHC.CmmToAsm.Reg.Liveness (
RegSet,
RegMap, emptyRegMap,
- BlockMap, mapEmpty,
+ BlockMap,
LiveCmmDecl,
InstrSR (..),
LiveInstr (..),
@@ -260,7 +260,7 @@ instance OutputableP Platform LiveInfo where
= (pdoc env mb_static)
$$ text "# entryIds = " <> ppr entryIds
$$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
- $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
+ $$ text "# liveSlotsOnEntry = " <> ppr liveSlotsOnEntry
=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -20,7 +20,7 @@ import GHC.Driver.Env.Types (HscEnv)
import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats))
import GHC.Driver.DynFlags (gopt, targetPlatform)
import GHC.Driver.Config.StgToCmm
-import GHC.Driver.Config.Cmm
+import GHC.Driver.Config.Cmm ( initCmmConfig )
import GHC.Prelude
import GHC.Runtime.Heap.Layout (isStackRep)
import GHC.Settings (platformTablesNextToCode)
@@ -36,6 +36,7 @@ import GHC.Unit.Module (moduleNameString)
import qualified GHC.Utils.Logger as Logger
import GHC.Utils.Outputable (ppr)
import GHC.Types.Unique.DSM
+import GHC.Cmm.UniqueRenamer
{-
Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
@@ -199,9 +200,10 @@ generateCgIPEStub
, Map CmmInfoTable (Maybe IpeSourceLocation)
, IPEStats
, DUniqSupply
+ , DetUniqFM
)
-> Stream IO CmmGroupSRTs CmmCgInfos
-generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats, dus) = do
+generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats, dus, detRnEnv) = do
let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
logger = hsc_logger hsc_env
@@ -213,7 +215,9 @@ generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesW
let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}
((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv')
- (_, _, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) dus ipeCmmGroup
+ (_detRnEnv', rn_ipeCmmGroup) = detRenameCmmGroup detRnEnv ipeCmmGroup
+
+ (_, _, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) dus rn_ipeCmmGroup
Stream.yield ipeCmmGroupSRTs
ipeStub <-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -214,6 +214,7 @@ import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Cmm.Parser
+import GHC.Cmm.UniqueRenamer
import GHC.Unit
import GHC.Unit.Env
@@ -299,7 +300,6 @@ import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
-import GHC.Types.Unique.DSM
import GHC.Cmm.Config (CmmConfig)
{- **********************************************************************
@@ -2120,12 +2120,14 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
mod_name = mkModuleName $ "Cmm$" ++ original_filename
cmm_mod = mkHomeModule home_unit mod_name
cmmpConfig = initCmmParserConfig dflags
- (cmm, ipe_ents) <- ioMsgMaybe
+ (dcmm, ipe_ents) <- ioMsgMaybe
$ do
(warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile cmmpConfig cmm_mod home_unit filename
let msgs = warns `unionMessages` errs
return (GhcPsMessage <$> msgs, cmm)
+ -- Probably need to rename cmm here
+ let cmm = removeDeterm dcmm
liftIO $ do
putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
@@ -2210,11 +2212,11 @@ doCodeGen hsc_env this_mod denv data_tycons
putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
(pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
- let stg_to_cmm dflags mod = case stgToCmmHook hooks of
- Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
- Just h -> h (initStgToCmmConfig dflags mod)
+ let stg_to_cmm dflags mod a b c d e = case stgToCmmHook hooks of
+ Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d e
+ Just h -> (,emptyDetUFM) <$> h (initStgToCmmConfig dflags mod) a b c d e
- let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
+ let cmm_stream :: Stream IO CmmGroup (ModuleLFInfos, DetUniqFM)
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
@@ -2236,11 +2238,11 @@ doCodeGen hsc_env this_mod denv data_tycons
pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos
pipeline_stream = do
- ((mod_srt_info, ipes, ipe_stats, dus), lf_infos) <-
+ ((mod_srt_info, ipes, ipe_stats, dus), (lf_infos, detRnEnv)) <-
{-# SCC "cmmPipeline" #-}
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)
+ cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats, dus, detRnEnv)
return cmmCgInfos
pipeline_action
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -11,6 +11,7 @@ import GHC.Prelude
import GHC.Stg.Syntax
+import GHC.Types.Unique.DFM
import GHC.Types.Id
import GHC.Types.Tickish
import GHC.Core.DataCon
@@ -166,13 +167,13 @@ numberDataCon dc ts = do
env <- lift get
mcc <- asks rSpan
let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)
- let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))
- (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc
+ let !dcMap' = alterUDFM (maybe (Just (dc, (0, mbest_span) :| [] ))
+ (\(_dc, xs@((k, _):|_)) -> Just $! (dc, (k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc
lift $ put (env { provDC = dcMap' })
- let r = lookupUniqMap dcMap' dc
+ let r = lookupUDFM dcMap' dc
return $ case r of
Nothing -> NoNumber
- Just res -> Numbered (fst (NE.head res))
+ Just (_, res) -> Numbered (fst (NE.head res))
selectTick :: [StgTickish] -> Maybe SpanWithLabel
selectTick [] = Nothing
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Types.Id.Info
import GHC.Types.RepType
import GHC.Types.Basic
import GHC.Types.Var.Set ( isEmptyDVarSet )
+import GHC.Types.Unique.DFM
import GHC.Types.Unique.FM
import GHC.Types.Name.Env
@@ -60,7 +61,6 @@ import GHC.Utils.TmpFs
import GHC.Data.Stream
import GHC.Data.OrdList
-import GHC.Types.Unique.Map
import Control.Monad (when,void, forM_)
import GHC.Utils.Misc
@@ -77,10 +77,11 @@ codeGen :: Logger
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
- -> Stream IO CmmGroup ModuleLFInfos -- Output as a stream, so codegen can
+ -> Stream IO CmmGroup (ModuleLFInfos, DetUniqFM)
+ -- Output as a stream, so codegen can
-- be interleaved with output
-codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
+codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
cost_centre_info stg_binds hpc_info
= do { -- cg: run the code generator, and yield the resulting CmmGroup
-- Using an IORef to store the state is a bit crude, but otherwise
@@ -103,8 +104,8 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
-- renaming uniques deterministically.
-- See Note [Object determinism]
if stgToCmmObjectDeterminism cfg
- then detRenameUniques rnm0 cmm -- The yielded cmm will already be renamed.
- else (rnm0, cmm)
+ then detRenameCmmGroup rnm0 cmm -- The yielded cmm will already be renamed.
+ else (rnm0, removeDeterm cmm)
-- NB. stub-out cgs_tops and cgs_stmts. This fixes
-- a big space leak. DO NOT REMOVE!
@@ -135,7 +136,7 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
-- Emit special info tables for everything used in this module
-- This will only do something if `-fdistinct-info-tables` is turned on.
- ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)
+ ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (eltsUDFM denv)
; final_state <- liftIO (readIORef cgref)
; let cg_id_infos = cgs_binds final_state
@@ -156,7 +157,7 @@ codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
; rn_mapping <- liftIO (readIORef uniqRnRef)
; liftIO $ debugTraceMsg logger 3 (text "DetRnM mapping:" <+> ppr rn_mapping)
- ; return generatedInfo
+ ; return (generatedInfo, rn_mapping)
}
{-
=====================================
compiler/GHC/StgToCmm/CgUtils.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Utils.Panic
+import GHC.Cmm.Dataflow.Label
-- -----------------------------------------------------------------------------
-- Information about global registers
@@ -132,7 +133,7 @@ fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl
fixStgRegisters _ top@(CmmData _ _) = top
fixStgRegisters platform (CmmProc info lbl live graph) =
- let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph
+ let graph' = modifyGraph (mapGraphBlocks mapMap (fixStgRegBlock platform)) graph
in CmmProc info lbl live graph'
fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x
=====================================
compiler/GHC/StgToCmm/Monad.hs
=====================================
@@ -76,7 +76,6 @@ import GHC.StgToCmm.Sequel
import GHC.Cmm.Graph as CmmGraph
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
-import GHC.Cmm.Dataflow.Label
import GHC.Runtime.Heap.Layout
import GHC.Unit
import GHC.Types.Id
@@ -285,7 +284,7 @@ data CgState
= MkCgState {
cgs_stmts :: CmmAGraph, -- Current procedure
- cgs_tops :: OrdList CmmDecl,
+ cgs_tops :: OrdList DCmmDecl,
-- Other procedures and data blocks in this compilation unit
-- Both are ordered only so that we can
-- reduce forward references, when it's easy to do so
@@ -744,7 +743,7 @@ emit ag
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }
-emitDecl :: CmmDecl -> FCode ()
+emitDecl :: DCmmDecl -> FCode ()
emitDecl decl
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
@@ -787,16 +786,16 @@ emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
emitProc mb_info lbl live blocks offset do_layout
= do { l <- newBlockId
; let
- blks :: CmmGraph
+ blks :: DCmmGraph
blks = labelAGraph l blocks
- infos | Just info <- mb_info = mapSingleton (g_entry blks) info
- | otherwise = mapEmpty
+ infos | Just info <- mb_info = [((g_entry blks), info)]
+ | otherwise = []
sinfo = StackInfo { arg_space = offset
, do_layout = do_layout }
- tinfo = TopInfo { info_tbls = infos
+ tinfo = TopInfo { info_tbls = DWrap infos
, stack_info=sinfo}
proc_block = CmmProc tinfo lbl live blks
@@ -804,7 +803,7 @@ emitProc mb_info lbl live blocks offset do_layout
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
-getCmm :: FCode a -> FCode (a, CmmGroup)
+getCmm :: FCode a -> FCode (a, DCmmGroup)
-- Get all the CmmTops (there should be no stmts)
-- Return a single Cmm which may be split from other Cmms by
-- object splitting (at a later stage)
@@ -880,7 +879,7 @@ mkCmmCall f results actuals updfr_off
-- ----------------------------------------------------------------------------
-- turn CmmAGraph into CmmGraph, for making a new proc.
-aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
+aGraphToGraph :: CmmAGraphScoped -> FCode DCmmGraph
aGraphToGraph stmts
= do { l <- newBlockId
; return (labelAGraph l stmts) }
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -90,7 +90,7 @@ import GHC.Types.Unique.Map
import Data.Maybe
import qualified Data.List.NonEmpty as NE
import GHC.Core.DataCon
-import GHC.Types.Unique.FM
+import GHC.Types.Unique.DFM
import GHC.Data.Maybe
import Control.Monad
import qualified Data.Map.Strict as Map
@@ -673,7 +673,7 @@ pprIPEStats (IPEStats{..}) =
-- for stack info tables skipped during 'generateCgIPEStub'. As the fold
-- progresses, counts of tables per closure type will be accumulated.
convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])
-convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) initStats cmits =
+convertInfoProvMap cfg this_mod (InfoTableProvMap dcenv denv infoTableToSourceLocationMap) initStats cmits =
foldl' convertInfoProvMap' (initStats, []) cmits
where
convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])
@@ -694,7 +694,7 @@ convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTable
lookupDataConMap = (closureIpeStats cn,) <$> do
UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation
-- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
- (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique
+ (dc, ns) <- hasHaskellName cl >>= lookupUDFM_Directly dcenv . getUnique
-- Lookup is linear but lists will be small (< 100)
return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)))
=====================================
compiler/GHC/Types/IPE.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Core.DataCon
+import GHC.Types.Unique.DFM
import GHC.Types.Unique.Map
import GHC.Core.Type
import Data.List.NonEmpty
@@ -38,7 +39,7 @@ type ClosureMap = UniqMap Name -- The binding
-- the constructor was used at, if possible and a string which names
-- the source location. This is the same information as is the payload
-- for the 'GHC.Core.SourceNote' constructor.
-type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation))
+type DCMap = UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation))
type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation)
@@ -49,4 +50,4 @@ data InfoTableProvMap = InfoTableProvMap
}
emptyInfoTableProvMap :: InfoTableProvMap
-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty
+emptyInfoTableProvMap = InfoTableProvMap emptyUDFM emptyUniqMap Map.empty
=====================================
compiler/GHC/Types/Name.hs
=====================================
@@ -716,9 +716,9 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ})
{-# SPECIALISE pprName :: Name -> SDoc #-}
{-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
--- | Print fully qualified name (with unit-id, module and unique)
+-- | Print fully qualified name (with unit-id, module but no unique)
pprFullName :: Module -> Name -> SDoc
-pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} =
+pprFullName this_mod Name{n_sort = sort, n_occ = occ} =
let mod = case sort of
WiredIn m _ _ -> m
External m -> m
@@ -727,8 +727,6 @@ pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} =
in ftext (unitIdFS (moduleUnitId mod))
<> colon <> ftext (moduleNameFS $ moduleName mod)
<> dot <> ftext (occNameFS occ)
- <> char '_' <> pprUniqueAlways uniq
-
-- | Print a ticky ticky styled name
--
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -43,10 +43,10 @@ module GHC.Types.Unique.DFM (
mapMaybeUDFM,
mapMUDFM,
plusUDFM,
- plusUDFM_C,
+ plusUDFM_C, plusUDFM_CK,
lookupUDFM, lookupUDFM_Directly,
elemUDFM,
- foldUDFM,
+ foldUDFM, foldWithKeyUDFM,
eltsUDFM,
filterUDFM, filterUDFM_Directly,
isNullUDFM,
@@ -56,6 +56,7 @@ module GHC.Types.Unique.DFM (
equalKeysUDFM,
minusUDFM,
listToUDFM, listToUDFM_Directly,
+ listToUDFM_C_Directly,
udfmMinusUFM, ufmMinusUDFM,
partitionUDFM,
udfmRestrictKeys,
@@ -224,6 +225,12 @@ addListToUDFM_Directly_C
addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)
{-# INLINEABLE addListToUDFM_Directly_C #-}
+-- | Like 'addListToUDFM_Directly_C' but also passes the unique key to the combine function
+addListToUDFM_Directly_CK
+ :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt
+addListToUDFM_Directly_CK f = foldl' (\m (k, v) -> addToUDFM_C_Directly (f k) m k v)
+{-# INLINEABLE addListToUDFM_Directly_CK #-}
+
delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt
delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
@@ -234,6 +241,15 @@ plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j)
| i > j = insertUDFMIntoLeft_C f udfml udfmr
| otherwise = insertUDFMIntoLeft_C f udfmr udfml
+-- | Like 'plusUDFM_C' but the combine function also receives the unique key
+plusUDFM_CK :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
+plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j)
+ -- we will use the upper bound on the tag as a proxy for the set size,
+ -- to insert the smaller one into the bigger one
+ | i > j = insertUDFMIntoLeft_CK f udfml udfmr
+ | otherwise = insertUDFMIntoLeft_CK f udfmr udfml
+
+
-- Note [Overflow on plusUDFM]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- There are multiple ways of implementing plusUDFM.
@@ -282,6 +298,12 @@ insertUDFMIntoLeft_C
insertUDFMIntoLeft_C f udfml udfmr =
addListToUDFM_Directly_C f udfml $ udfmToList udfmr
+-- | Like 'insertUDFMIntoLeft_C', but the merge function also receives the unique key
+insertUDFMIntoLeft_CK
+ :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
+insertUDFMIntoLeft_CK f udfml udfmr =
+ addListToUDFM_Directly_CK f udfml $ udfmToList udfmr
+
lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt
lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m
@@ -298,6 +320,12 @@ foldUDFM :: (elt -> a -> a) -> a -> UniqDFM key elt -> a
-- This INLINE prevents a regression in !10568
foldUDFM k z m = foldr k z (eltsUDFM m)
+-- | Like 'foldUDFM' but the function also receives a key
+foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a
+{-# INLINE foldWithKeyUDFM #-}
+-- This INLINE was copied from foldUDFM
+foldWithKeyUDFM k z m = foldr (uncurry k) z (udfmToList m)
+
-- | Performs a nondeterministic strict fold over the UniqDFM.
-- It's O(n), same as the corresponding function on `UniqFM`.
-- If you use this please provide a justification why it doesn't introduce
@@ -397,6 +425,9 @@ listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM
listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt
listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM
+listToUDFM_C_Directly :: (elt -> elt -> elt) -> [(Unique, elt)] -> UniqDFM key elt
+listToUDFM_C_Directly f = foldl' (\m (u, v) -> addToUDFM_C_Directly f m u v) emptyUDFM
+
-- | Apply a function to a particular element
adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt
adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -142,6 +142,7 @@ import Data.Int
import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
+import qualified Data.IntSet as IntSet
import qualified GHC.Data.Word64Set as Word64Set
import Data.String
import Data.Word
@@ -991,6 +992,9 @@ instance (Outputable a) => Outputable (Set a) where
instance Outputable Word64Set.Word64Set where
ppr s = braces (pprWithCommas ppr (Word64Set.toList s))
+instance Outputable IntSet.IntSet where
+ ppr s = braces (pprWithCommas ppr (IntSet.toList s))
+
instance (Outputable a, Outputable b) => Outputable (a, b) where
ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
=====================================
testsuite/tests/regalloc/regalloc_unit_tests.hs
=====================================
@@ -137,7 +137,9 @@ compileCmmForRegAllocStats logger home_unit dflags cmmFile ncgImplF us = do
-- parse the cmm file and output any warnings or errors
let fake_mod = mkHomeModule home_unit (mkModuleName "fake")
cmmpConfig = initCmmParserConfig dflags
- (warnings, errors, parsedCmm) <- parseCmmFile cmmpConfig fake_mod home_unit cmmFile
+ (warnings, errors, dparsedCmm) <- parseCmmFile cmmpConfig fake_mod home_unit cmmFile
+
+ let parsedCmm = removeDeterm (fst (fromJust dparsedCmm))
-- print parser errors or warnings
let !diag_opts = initDiagOpts dflags
=====================================
testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
=====================================
@@ -120,7 +120,7 @@ slurpCmm hsc_env filename = runHsc hsc_env $ do
$ parseCmmFile cmmpConfig cmm_mod home_unit filename
let msgs = warns `unionMessages` errs
return (GhcPsMessage <$> msgs, cmm)
- return cmm
+ return (removeDeterm cmm)
collectAll :: Monad m => Stream m a b -> m ([a], b)
collectAll = gobble . runStream
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3dc7d298060098fdf864dc83e87152521f11d212...f446aa3cdaccc492d3ac1b07593e536b3d9590ef
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3dc7d298060098fdf864dc83e87152521f11d212...f446aa3cdaccc492d3ac1b07593e536b3d9590ef
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/20240905/56e3c8e8/attachment-0001.html>
More information about the ghc-commits
mailing list