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