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/BlockId.hs

@@ -15,7 +15,7 @@ import GHC.Data.FastString
 import GHC.Types.Id.Info
 import GHC.Types.Name
 import GHC.Types.Unique
-import GHC.Types.Unique.Supply
+import qualified GHC.Types.Unique.DSM as DSM
 
 import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel)
 
@@ -36,8 +36,12 @@ type BlockId = Label
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = mkHooplLabel $ getKey unique
 
-newBlockId :: MonadUnique m => m BlockId
-newBlockId = mkBlockId <$> getUniqueM
+-- If the monad unique instance uses a deterministic unique supply, this will
+-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm
+-- onwards (after deterministic renaming in 'codeGen'), there should only exist
+-- deterministic block labels.
+newBlockId :: DSM.MonadGetUnique m => m BlockId
+newBlockId = mkBlockId <$> DSM.getUniqueM
 
 blockLbl :: BlockId -> CLabel
 blockLbl label = mkLocalBlockLabel (getUnique label)

compiler/GHC/Cmm/CLabel.hs

@@ -139,6 +139,7 @@ module GHC.Cmm.CLabel (
         CStubLabel (..),
         cStubLabel,
         fromCStubLabel,
+        mapInternalNonDetUniques
     ) where
 
 import GHC.Prelude
@@ -346,7 +347,14 @@ newtype NeedExternDecl
 -- This is non-deterministic but we do not currently support deterministic
 -- code-generation. See Note [Unique Determinism and code generation]
 instance Ord CLabel where
+  compare (IdLabel a1 b1 c1)
+          (IdLabel a2 b2 c2)
+          | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2
+          | isExternalName a1 = GT
+          | isExternalName a2 = LT
+
   compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+    -- Comparing names here should deterministic because all unique should have been renamed deterministically ......
     compare a1 a2 S.<>
     compare b1 b2 S.<>
     compare c1 c2
@@ -1906,3 +1914,35 @@ fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =
       if csl_is_initializer
       then MLK_Initializer
       else MLK_Finalizer
+
+-- | A utility for renaming uniques in CLabels to produce deterministic object.
+-- Note that not all Uniques are mapped over. Only those that can be safely alpha
+-- renamed, e.g. uniques of local symbols, but not of external ones.
+-- See Note [Renaming uniques deterministically].
+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel
+-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel?
+mapInternalNonDetUniques f x = case x of
+  IdLabel name cafInfo idLabelInfo
+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
+    | otherwise -> pure x
+  cl@CmmLabel{} -> pure cl
+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo
+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique
+  fl@ForeignLabel{} -> pure fl
+  AsmTempLabel unique -> AsmTempLabel <$> f unique
+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs
+  StringLitLabel unique -> StringLitLabel <$> f unique
+  CC_Label  cc -> pure $ CC_Label cc
+  CCS_Label ccs -> pure $ CCS_Label ccs
+  IPE_Label ipe@InfoProvEnt{infoTablePtr} ->
+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr
+  ml@ModuleLabel{} -> pure ml
+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl
+  PicBaseLabel -> pure PicBaseLabel
+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl
+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod
+  SRTLabel unique -> SRTLabel <$> f unique
+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique
+-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma:
+{-# INLINABLE mapInternalNonDetUniques #-}
+

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.Types.Unique.DSM
 
 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@.
 --
--- 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/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

@@ -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.Types.Unique.DSM
 import GHC.Utils.Constants (debugIsOn)
 import GHC.Utils.Panic
 
@@ -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 -> UniqSM CmmGraph
+lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM DCmmGraph
 lgraphOfAGraph g = do
-  u <- getUniqueM
+  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/Info.hs

@@ -47,13 +47,14 @@ import GHC.Platform.Profile
 import GHC.Data.Maybe
 import GHC.Utils.Error (withTimingSilent)
 import GHC.Utils.Panic
-import GHC.Types.Unique.Supply
 import GHC.Utils.Logger
 import GHC.Utils.Monad
 import GHC.Utils.Misc
 import GHC.Utils.Outputable
+import GHC.Types.Unique.DSM
 
 import Data.ByteString (ByteString)
+import Data.IORef
 
 -- When we split at proc points, we need an empty info table.
 mkEmptyContInfoTable :: CLabel -> CmmInfoTable
@@ -67,16 +68,22 @@ mkEmptyContInfoTable info_lbl
 cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
             -> IO (Stream IO RawCmmGroup a)
 cmmToRawCmm logger profile cmms
-  = do {
+  = do { detUqSupply <- newIORef (initDUniqSupply 'i' 1)
        ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
              do_one cmm = do
-               uniqs <- mkSplitUniqSupply 'i'
                -- NB. strictness fixes a space leak.  DO NOT REMOVE.
-               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ())
-                  -- TODO: It might be better to make `mkInfoTable` run in
-                  -- IO as well so we don't have to pass around
-                  -- a UniqSupply (see #16843)
-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)
+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) $ do
+                 -- We have to store the deterministic unique supply
+                 -- to produce uniques across cmm decls.
+                 nextUq <- readIORef detUqSupply
+                 -- By using a local namespace 'i' here, we can have other
+                 -- deterministic supplies starting from the same unique in
+                 -- other parts of the Cmm backend
+                 -- See Note [Deterministic Uniques in the NCG]
+                 let (a, us) = runUniqueDSM nextUq $
+                               concatMapM (mkInfoTable profile) cmm
+                 writeIORef detUqSupply us
+                 return a
        ; return (Stream.mapM do_one cmms)
        }
 
@@ -114,7 +121,7 @@ cmmToRawCmm logger profile cmms
 --
 --  * The SRT slot is only there if there is SRT info to record
 
-mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
+mkInfoTable :: Profile -> CmmDeclSRTs -> UniqDSM [RawCmmDecl]
 mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]
 
 mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)
@@ -177,7 +184,7 @@ type InfoTableContents = ( [CmmLit]          -- The standard part
 mkInfoTableContents :: Profile
                     -> CmmInfoTable
                     -> Maybe Int               -- Override default RTS type tag?
-                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
+                    -> UniqDSM ([RawCmmDecl],             -- Auxiliary top decls
                                InfoTableContents)       -- Info tbl + extra bits
 
 mkInfoTableContents profile
@@ -218,10 +225,10 @@ mkInfoTableContents profile
   where
     platform = profilePlatform profile
     mk_pieces :: ClosureTypeInfo -> [CmmLit]
-              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
-                        , Maybe CmmLit  -- Override the layout field with this
-                        , [CmmLit]           -- "Extra bits" for info table
-                        , [RawCmmDecl])      -- Auxiliary data decls
+              -> UniqDSM ( Maybe CmmLit  -- Override the SRT field with this
+                         , Maybe CmmLit  -- Override the layout field with this
+                         , [CmmLit]           -- "Extra bits" for info table
+                         , [RawCmmDecl])      -- Auxiliary data decls
     mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
       = do { (descr_lit, decl) <- newStringLit con_descr
            ; return ( Just (CmmInt (fromIntegral con_tag)
@@ -338,14 +345,14 @@ makeRelativeRefTo platform info_lbl lit
 -- The head of the stack layout is the top of the stack and
 -- the least-significant bit.
 
-mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
+mkLivenessBits :: Platform -> Liveness -> UniqDSM (CmmLit, [RawCmmDecl])
               -- ^ Returns:
               --   1. The bitmap (literal value or label)
               --   2. Large bitmap CmmData if needed
 
 mkLivenessBits platform liveness
   | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word
-  = do { uniq <- getUniqueM
+  = do { uniq <- getUniqueDSM
        ; let bitmap_lbl = mkBitmapLabel uniq
        ; return (CmmLabel bitmap_lbl,
                  [mkRODataLits bitmap_lbl lits]) }
@@ -412,16 +419,16 @@ mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit
 --
 -------------------------------------------------------------------------
 
-mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits :: Platform -> ProfilingInfo -> UniqDSM ((CmmLit,CmmLit), [RawCmmDecl])
 mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
 mkProfLits _ (ProfilingInfo td cd)
   = do { (td_lit, td_decl) <- newStringLit td
        ; (cd_lit, cd_decl) <- newStringLit cd
        ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
 
-newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
+newStringLit :: ByteString -> UniqDSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
 newStringLit bytes
-  = do { uniq <- getUniqueM
+  = do { uniq <- getUniqueDSM
        ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
 
 

compiler/GHC/Cmm/Info/Build.hs

@@ -9,6 +9,10 @@ module GHC.Cmm.Info.Build
   ( CAFSet, CAFEnv, cafAnal, cafAnalData
   , doSRTs, ModuleSRTInfo (..), emptySRT
   , SRTMap, srtMapNonCAFs
+
+  -- * Some internal bits
+  , SRTEntry(..)
+  , CAFfyLabel(..)
   ) where
 
 import GHC.Prelude hiding (succ)
@@ -33,7 +37,6 @@ import GHC.Data.Maybe
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Runtime.Heap.Layout
-import GHC.Types.Unique.Supply
 import GHC.Types.CostCentre
 import GHC.StgToCmm.Heap
 
@@ -47,6 +50,7 @@ import Control.Monad.Trans.Class
 import Data.List (unzip4)
 
 import GHC.Types.Name.Set
+import GHC.Types.Unique.DSM
 
 {- Note [SRTs]
    ~~~~~~~~~~~
@@ -878,13 +882,14 @@ anyCafRefs caf_infos = case any mayHaveCafRefs caf_infos of
 doSRTs
   :: CmmConfig
   -> ModuleSRTInfo
+  -> DUniqSupply
   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks
   -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's
-  -> IO (ModuleSRTInfo, [CmmDeclSRTs])
+  -> IO (ModuleSRTInfo, DUniqSupply, [CmmDeclSRTs])
 
-doSRTs cfg moduleSRTInfo procs data_ = do
-  us <- mkSplitUniqSupply 'u'
+doSRTs cfg moduleSRTInfo dus procs data_ = do
 
+  let runUDSM = runUniqueDSM dus
   let profile = cmmProfile cfg
 
   -- Ignore the original grouping of decls, and combine all the
@@ -936,8 +941,8 @@ doSRTs cfg moduleSRTInfo procs data_ = do
           , CafInfo                -- Whether the group has CAF references
           ) ]
 
-      (result, moduleSRTInfo') =
-        initUs_ us $
+      ((result, moduleSRTInfo'), dus') =
+        runUDSM $
         flip runStateT moduleSRTInfo $ do
           nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs
           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
@@ -977,7 +982,7 @@ doSRTs cfg moduleSRTInfo procs data_ = do
                     CmmProc void _ _ _ -> case void of)
                (moduleSRTMap moduleSRTInfo') data_
 
-  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
+  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, dus', srt_decls ++ decls')
 
 
 -- | Build the SRT for a strongly-connected component of blocks.
@@ -986,7 +991,7 @@ doSCC
   -> LabelMap CLabel -- ^ which blocks are static function entry points
   -> DataCAFEnv      -- ^ static data
   -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)
-  -> StateT ModuleSRTInfo UniqSM
+  -> StateT ModuleSRTInfo UniqDSM
         ( [CmmDeclSRTs]          -- generated SRTs
         , [(Label, CLabel)]      -- SRT fields for info tables
         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
@@ -1041,7 +1046,7 @@ oneSRT
   -> Bool                       -- ^ True <=> this SRT is for a CAF
   -> Set CAFfyLabel             -- ^ SRT for this set
   -> DataCAFEnv                 -- Static data labels in this group
-  -> StateT ModuleSRTInfo UniqSM
+  -> StateT ModuleSRTInfo UniqDSM
        ( [CmmDeclSRTs]                -- SRT objects we built
        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
@@ -1108,7 +1113,7 @@ oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do
     -- update the SRTMap for the label to point to a closure. It's
     -- important that we don't do this for static functions or CAFs,
     -- see Note [Invalid optimisation: shortcutting].
-    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
+    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqDSM ()
     updateSRTMap srtEntry =
       srtTrace "updateSRTMap"
         (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>
@@ -1232,7 +1237,7 @@ oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do
 buildSRTChain
    :: Profile
    -> [SRTEntry]
-   -> UniqSM
+   -> UniqDSM
         ( [CmmDeclSRTs] -- The SRT object(s)
         , SRTEntry      -- label to use in the info table
         )
@@ -1250,9 +1255,9 @@ buildSRTChain profile cafSet =
     mAX_SRT_SIZE = 16
 
 
-buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
+buildSRT :: Profile -> [SRTEntry] -> UniqDSM (CmmDeclSRTs, SRTEntry)
 buildSRT profile refs = do
-  id <- getUniqueM
+  id <- getUniqueDSM
   let
     lbl = mkSRTLabel id
     platform = profilePlatform profile

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      ( newTemp ) -- XXX layering violation
 import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation
 import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation
 
@@ -25,9 +25,9 @@ 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.Data.Maybe
 import GHC.Types.Unique.FM
+import GHC.Types.Unique.DSM
 import GHC.Utils.Misc
 
 import GHC.Utils.Outputable hiding ( isEmpty )
@@ -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
@@ -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)
 
@@ -436,7 +442,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 +508,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 +541,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 +576,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 +1053,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,7 +1139,7 @@ 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
@@ -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/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.Types.Unique.DSM
+import GHC.Types.Unique
 
 import GHC.Utils.Misc
 import GHC.Utils.Panic
@@ -681,7 +681,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)
 
@@ -771,7 +771,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
@@ -862,7 +862,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])
@@ -914,16 +914,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
@@ -943,10 +943,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/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/Pipeline.hs

@@ -21,15 +21,17 @@ import GHC.Cmm.Switch.Implement
 import GHC.Cmm.ThreadSanitizer
 
 import GHC.Types.Unique.Supply
+import GHC.Types.Unique.DSM
 
 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.Utils.Monad (mapAccumLM)
 
 -----------------------------------------------------------------------------
 -- | Top level driver for C-- pipeline
@@ -42,19 +44,20 @@ cmmPipeline
  :: Logger
  -> CmmConfig
  -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> DUniqSupply
  -> CmmGroup             -- Input C-- with Procedures
- -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--
+ -> IO (ModuleSRTInfo, DUniqSupply, CmmGroupSRTs) -- Output CPS transformed C--
 
-cmmPipeline logger cmm_config srtInfo prog = do
-  let forceRes (info, group) = info `seq` foldr seq () group
+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) prog
-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo 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, cmms)
-
+     return (srtInfo, dus, cmms)
 
 -- | The Cmm pipeline for a single 'CmmDecl'. Returns:
 --
@@ -64,9 +67,10 @@ cmmPipeline logger cmm_config srtInfo 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) = return (Right (cafAnalData platform statics, CmmData section statics))
-cpsTop logger platform cfg proc =
+cpsTop :: Logger -> Platform -> CmmConfig -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))
+cpsTop _logger platform _ dus (CmmData section statics) =
+  return (dus, Right (cafAnalData platform statics, CmmData section statics))
+cpsTop logger platform cfg dus proc =
     do
       ----------- Control-flow optimisations ----------------------------------
 
@@ -76,7 +80,7 @@ cpsTop logger platform cfg proc =
       --
       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
            return $ cmmCfgOptsProc splitting_proc_points proc
-      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g
 
       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
                                          , do_layout = do_layout }} = h
@@ -90,16 +94,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
 
@@ -107,30 +116,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
 
 
@@ -138,21 +147,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" #-}
@@ -166,9 +175,9 @@ cpsTop logger platform cfg proc =
                     else g
       g <- return $ map (removeUnreachableBlocksProc platform) g
            -- See Note [unreachable blocks]
-      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+      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)
 
@@ -352,12 +361,6 @@ generator later.
 
 -}
 
-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.Types.Unique.DSM
 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/Reducibility.hs

@@ -47,7 +47,7 @@ import GHC.Cmm.Dataflow.Label
 import GHC.Data.Graph.Collapse
 import GHC.Data.Graph.Inductive.Graph
 import GHC.Data.Graph.Inductive.PatriciaTree
-import GHC.Types.Unique.Supply
+import GHC.Types.Unique.DSM
 import GHC.Utils.Panic
 
 -- | Represents the result of a reducibility analysis.
@@ -81,7 +81,7 @@ reducibility gwd =
 -- control-flow graph.
 
 asReducible :: GraphWithDominators CmmNode
-            -> UniqSM (GraphWithDominators CmmNode)
+            -> UniqDSM (GraphWithDominators CmmNode)
 asReducible gwd = case reducibility gwd of
                     Reducible -> return gwd
                     Irreducible -> assertReducible <$> nodeSplit gwd
@@ -97,7 +97,7 @@ assertReducible gwd = case reducibility gwd of
 -- irreducible.
 
 nodeSplit :: GraphWithDominators CmmNode
-          -> UniqSM (GraphWithDominators CmmNode)
+          -> UniqDSM (GraphWithDominators CmmNode)
 nodeSplit gwd =
     graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed
   where g = gwd_graph gwd
@@ -181,7 +181,7 @@ instance PureSupernode CmmSuper where
   mapLabels = changeLabels
 
 instance Supernode CmmSuper NullCollapseViz where
-  freshen s = liftUniqSM $ relabel s
+  freshen s = liftUniqDSM $ relabel s
 
 
 -- | Return all labels defined within a supernode.
@@ -212,11 +212,11 @@ changeBlockLabels f block = blockJoin entry' middle exit'
 -- | Within the given supernode, replace every defined label (and all
 -- of its uses) with a fresh label.
 
-relabel :: CmmSuper -> UniqSM CmmSuper
+relabel :: CmmSuper -> UniqDSM CmmSuper
 relabel node = do
      finite_map <- foldM addPair mapEmpty $ definedLabels node
      return $ changeLabels (labelChanger finite_map) node
-  where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)
+  where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)
         addPair map old = do new <- newBlockId
                              return $ mapInsert old new map
         labelChanger :: LabelMap Label -> (Label -> Label)

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.Types.Unique.DSM
 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.hs

@@ -4,7 +4,7 @@ module GHC.Cmm.Switch (
      SwitchTargets,
      mkSwitchTargets,
      switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
-     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+     mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough,
      switchTargetsToList, eqSwitchTargetWith,
 
      SwitchPlan(..),
@@ -136,6 +136,11 @@ mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
 mapSwitchTargets f (SwitchTargets signed range mbdef branches)
     = SwitchTargets signed range (fmap f mbdef) (fmap f branches)
 
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets
+mapSwitchTargetsA f (SwitchTargets signed range mbdef branches)
+    = SwitchTargets signed range <$> traverse f mbdef <*> traverse f branches
+
 -- | Returns the list of non-default branches of the SwitchTargets value
 switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
 switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches

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.Types.Unique.DSM
 
 --
 -- 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/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/Cmm/UniqueRenamer.hs

+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
+module GHC.Cmm.UniqueRenamer
+  ( detRenameCmmGroup
+  , MonadGetUnique(..)
+
+  -- Careful! Not for general use!
+  , DetUniqFM, emptyDetUFM
+
+  , module GHC.Types.Unique.DSM
+  )
+  where
+
+import Prelude
+import GHC.Utils.Monad.State.Strict
+import Data.Tuple (swap)
+import GHC.Word
+import GHC.Cmm
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Switch
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import GHC.Utils.Outputable as Outputable
+import GHC.Types.Id
+import GHC.Types.Unique.DSM
+import GHC.Types.Name hiding (varName)
+import GHC.Types.Var
+
+
+{-
+Note [Renaming uniques deterministically]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+TODO:::::::
+To produce deterministic object code, we alpha-rename all Uniques to deterministic uniques before Cmm linting.
+From here on out, the backend code generation can't use (non-deterministic) Uniques, or risk producing non-deterministic code.
+For example, the fix-up action in the ASM NCG should use deterministic names for potential new blocks it has to create.
+Therefore, in the ASM NCG `NatM` Monad we use a deterministic `UniqSuply` (which won't be shared about multiple threads)
+
+Before generating Code, we rename all uniques of local symbols deterministically
+
+See also Note [Object determinism] in GHC.StgToCmm
+-}
+
+-- | A mapping from non-deterministic uniques to deterministic uniques, to
+-- rename local symbols with the end goal of producing deterministic object files.
+-- See Note [Renaming uniques deterministically]
+data DetUniqFM = DetUniqFM
+  { mapping :: !(UniqFM Unique Unique)
+  , supply  :: !Word64
+  }
+
+instance Outputable DetUniqFM where
+  ppr DetUniqFM{mapping, supply} =
+    ppr mapping $$
+    text "supply:" Outputable.<> ppr supply
+
+type DetRnM = State DetUniqFM
+
+emptyDetUFM :: DetUniqFM
+emptyDetUFM = DetUniqFM
+  { mapping = emptyUFM
+  -- NB: A lower initial value can get us label `Lsl` which is not parsed
+  -- correctly in older versions of LLVM assembler (llvm-project#80571)
+  -- So we use an `x` s.t. w64ToBase62 x > "R" > "L" > "r" > "l"
+  , supply = 54
+  }
+
+renameDetUniq :: Unique -> DetRnM Unique
+renameDetUniq uq = do
+  m <- gets mapping
+  case lookupUFM m uq of
+    Nothing -> do
+      new_w <- gets supply -- New deterministic unique in this `DetRnM`
+      let --(_, _) = unpkUnique uq
+          -- TODO: DO NOT LEAVE IT LIKE THIS?
+          det_uniq = mkUnique 'Q' new_w
+      modify (\DetUniqFM{mapping, supply} ->
+        -- Update supply and mapping
+        DetUniqFM
+          { mapping = addToUFM mapping uq det_uniq
+          , supply = supply + 1
+          })
+      return det_uniq
+    Just det_uniq ->
+      return det_uniq
+
+-- The most important function here, which does the actual renaming.
+detRenameCLabel :: CLabel -> DetRnM CLabel
+detRenameCLabel = mapInternalNonDetUniques renameDetUniq
+
+-- | We want to rename uniques in Ids, but ONLY internal ones.
+detRenameId :: Id -> DetRnM Id
+detRenameId i
+  | isExternalName (varName i) = return i
+  | otherwise = setIdUnique i <$> renameDetUniq (getUnique i)
+
+detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup)
+detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm)
+  where
+    detRenameCmmDecl :: DCmmDecl -> DetRnM CmmDecl
+    detRenameCmmDecl (CmmProc h lbl regs g)
+      = do
+        -- Rename the cmm graph first, where things that need to be renamed
+        -- appear in a deterministic order.
+        g' <- detRenameCmmGraph g
+        regs' <- mapM detRenameGlobalReg regs
+        lbl' <- detRenameCLabel lbl
+        -- Rename the info table last! This is necessary for determinism, the
+        -- info table contents not always appear in the same order accross
+        -- runs. As long as all uniques have already been renamed in a deterministic
+        -- order, renaming the info table uniques will only lookup the
+        -- corresponding deterministic ones rather than creating any.
+        h' <- detRenameCmmTop h
+        return (CmmProc h' lbl' regs' g')
+    detRenameCmmDecl (CmmData sec d)
+      = CmmData <$> detRenameSection sec <*> detRenameCmmStatics d
+
+    detRenameCmmTop :: DCmmTopInfo -> DetRnM CmmTopInfo
+    detRenameCmmTop (TopInfo (DWrap i) b)
+      = TopInfo . mapFromList <$> mapM (detRenamePair detRenameLabel detRenameCmmInfoTable) i <*> pure b
+
+    detRenameCmmGraph :: DCmmGraph -> DetRnM CmmGraph
+    detRenameCmmGraph (CmmGraph entry bs)
+      = CmmGraph <$> detRenameLabel entry <*> detRenameGraph bs
+
+    detRenameGraph = \case
+      GNil  -> pure GNil
+      GUnit block -> GUnit <$> detRenameBlock block
+      GMany m1 b m2 -> GMany <$> detRenameMaybeBlock m1 <*> detRenameBody b <*> detRenameMaybeBlock m2
+
+    detRenameBody (DWrap b)
+      = mapFromList <$> mapM (detRenamePair detRenameLabel detRenameBlock) b
+
+    detRenameCmmStatics :: CmmStatics -> DetRnM CmmStatics
+    detRenameCmmStatics
+      (CmmStatics clbl info ccs lits1 lits2)
+        = CmmStatics <$> detRenameCLabel clbl <*> detRenameCmmInfoTable info <*> pure ccs <*> mapM detRenameCmmLit lits1 <*> mapM detRenameCmmLit lits2
+    detRenameCmmStatics
+      (CmmStaticsRaw lbl sts)
+        = CmmStaticsRaw <$> detRenameCLabel lbl <*> mapM detRenameCmmStatic sts
+
+    detRenameCmmInfoTable :: CmmInfoTable -> DetRnM CmmInfoTable
+    detRenameCmmInfoTable
+      CmmInfoTable{cit_lbl, cit_rep, cit_prof, cit_srt, cit_clo}
+        = CmmInfoTable <$> detRenameCLabel cit_lbl <*> pure cit_rep <*> pure cit_prof <*> detRenameMaybe detRenameCLabel cit_srt <*>
+           (case cit_clo of
+              Nothing -> pure Nothing
+              Just (an_id, ccs) -> Just . (,ccs) <$> detRenameId an_id)
+
+    detRenameCmmStatic :: CmmStatic -> DetRnM CmmStatic
+    detRenameCmmStatic = \case
+      CmmStaticLit l -> CmmStaticLit <$> detRenameCmmLit l
+      CmmUninitialised x -> pure $ CmmUninitialised x
+      CmmString x -> pure $ CmmString x
+      CmmFileEmbed f i -> pure $ CmmFileEmbed f i
+
+    detRenameCmmLit :: CmmLit -> DetRnM CmmLit
+    detRenameCmmLit = \case
+      CmmInt i w -> pure $ CmmInt i w
+      CmmFloat r w -> pure $ CmmFloat r w
+      CmmVec lits -> CmmVec <$> mapM detRenameCmmLit lits
+      CmmLabel lbl -> CmmLabel <$> detRenameCLabel lbl
+      CmmLabelOff lbl i -> CmmLabelOff <$> detRenameCLabel lbl <*> pure i
+      CmmLabelDiffOff lbl1 lbl2 i w ->
+        CmmLabelDiffOff <$> detRenameCLabel lbl1 <*> detRenameCLabel lbl2 <*> pure i <*> pure w
+      CmmBlock bid -> CmmBlock <$> detRenameLabel bid
+      CmmHighStackMark -> pure CmmHighStackMark
+
+    detRenameMaybeBlock :: MaybeO n (Block CmmNode a b) -> DetRnM (MaybeO n (Block CmmNode a b))
+    detRenameMaybeBlock (JustO x) = JustO <$> detRenameBlock x
+    detRenameMaybeBlock NothingO = pure NothingO
+
+    detRenameBlock :: Block CmmNode n m -> DetRnM (Block CmmNode n m)
+    detRenameBlock = \case
+      BlockCO n bn -> BlockCO <$> detRenameCmmNode n <*> detRenameBlock bn
+      BlockCC n1 bn n2 -> BlockCC <$> detRenameCmmNode n1 <*> detRenameBlock bn <*> detRenameCmmNode n2
+      BlockOC bn n -> BlockOC <$> detRenameBlock bn <*> detRenameCmmNode n
+      BNil    -> pure BNil
+      BMiddle n -> BMiddle <$> detRenameCmmNode n
+      BCat    b1 b2 -> BCat <$> detRenameBlock b1 <*> detRenameBlock b2
+      BSnoc   bn n -> BSnoc <$> detRenameBlock bn <*> detRenameCmmNode n
+      BCons   n bn -> BCons <$> detRenameCmmNode n <*> detRenameBlock bn
+
+    detRenameCmmNode :: CmmNode n m -> DetRnM (CmmNode n m)
+    detRenameCmmNode = \case
+      CmmEntry l t -> CmmEntry <$> detRenameLabel l <*> detRenameCmmTick t
+      CmmComment fs -> pure $ CmmComment fs
+      CmmTick tickish -> pure $ CmmTick tickish
+      CmmUnwind xs -> CmmUnwind <$> mapM (detRenamePair detRenameGlobalReg (detRenameMaybe detRenameCmmExpr)) xs
+      CmmAssign reg e -> CmmAssign <$> detRenameCmmReg reg <*> detRenameCmmExpr e
+      CmmStore e1 e2 align -> CmmStore <$> detRenameCmmExpr e1 <*> detRenameCmmExpr e2 <*> pure align
+      CmmUnsafeForeignCall ftgt cmmformal cmmactual ->
+        CmmUnsafeForeignCall <$> detRenameForeignTarget ftgt <*> mapM detRenameLocalReg cmmformal <*> mapM detRenameCmmExpr cmmactual
+      CmmBranch l -> CmmBranch <$> detRenameLabel l
+      CmmCondBranch pred t f likely ->
+        CmmCondBranch <$> detRenameCmmExpr pred <*> detRenameLabel t <*> detRenameLabel f <*> pure likely
+      CmmSwitch e sts -> CmmSwitch <$> detRenameCmmExpr e <*> mapSwitchTargetsA detRenameLabel sts
+      CmmCall tgt cont regs args retargs retoff ->
+        CmmCall <$> detRenameCmmExpr tgt <*> detRenameMaybe detRenameLabel cont <*> mapM detRenameGlobalReg regs
+                <*> pure args <*> pure retargs <*> pure retoff
+      CmmForeignCall tgt res args succ retargs retoff intrbl ->
+        CmmForeignCall <$> detRenameForeignTarget tgt <*> mapM detRenameLocalReg res <*> mapM detRenameCmmExpr args
+                       <*> detRenameLabel succ <*> pure retargs <*> pure retoff <*> pure intrbl
+
+    detRenameCmmExpr :: CmmExpr -> DetRnM CmmExpr
+    detRenameCmmExpr = \case
+      CmmLit l -> CmmLit <$> detRenameCmmLit l
+      CmmLoad e t a -> CmmLoad <$> detRenameCmmExpr e <*> pure t <*> pure a
+      CmmReg r -> CmmReg <$> detRenameCmmReg r
+      CmmMachOp mop es -> CmmMachOp mop <$> mapM detRenameCmmExpr es
+      CmmStackSlot a i -> CmmStackSlot <$> detRenameArea a <*> pure i
+      CmmRegOff r i -> CmmRegOff <$> detRenameCmmReg r <*> pure i
+
+    detRenameForeignTarget :: ForeignTarget -> DetRnM ForeignTarget
+    detRenameForeignTarget = \case
+        ForeignTarget e fc -> ForeignTarget <$> detRenameCmmExpr e <*> pure fc
+        PrimTarget cmop -> pure $ PrimTarget cmop
+
+    detRenameArea :: Area -> DetRnM Area
+    detRenameArea Old = pure Old
+    detRenameArea (Young l) = Young <$> detRenameLabel l
+
+    detRenameLabel :: Label -> DetRnM Label
+    detRenameLabel lbl
+      = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)
+
+    detRenameSection :: Section -> DetRnM Section
+    detRenameSection (Section ty lbl)
+      = Section ty <$> detRenameCLabel lbl
+
+    detRenameCmmReg :: CmmReg -> DetRnM CmmReg
+    detRenameCmmReg = \case
+      CmmLocal l -> CmmLocal <$> detRenameLocalReg l
+      CmmGlobal x -> pure $ CmmGlobal x
+
+    detRenameLocalReg :: LocalReg -> DetRnM LocalReg
+    detRenameLocalReg (LocalReg uq t)
+      = LocalReg <$> renameDetUniq uq <*> pure t
+
+    detRenameGlobalReg :: GlobalReg -> DetRnM GlobalReg
+    detRenameGlobalReg = pure -- Nothing needs to be renamed here
+
+    -- todo: We may have to change this to get deterministic objects with ticks.
+    detRenameCmmTick :: CmmTickScope -> DetRnM CmmTickScope
+    detRenameCmmTick = pure
+
+    detRenameMaybe _ Nothing = pure Nothing
+    detRenameMaybe f (Just x) = Just <$> f x
+
+    detRenamePair f g (a, b) = (,) <$> f a <*> g b

compiler/GHC/CmmToAsm.hs

@@ -100,7 +100,7 @@ import GHC.Cmm.GenericOpt
 import GHC.Cmm.CLabel
 
 import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
+import GHC.Types.Unique.DSM
 import GHC.Driver.DynFlags
 import GHC.Driver.Ppr
 import GHC.Utils.Misc
@@ -129,7 +129,7 @@ import System.IO
 import System.Directory ( getCurrentDirectory )
 
 --------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply
+nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> DUniqSupply
               -> Stream IO RawCmmGroup a
               -> IO a
 nativeCodeGen logger ts config modLoc h us cmms
@@ -203,7 +203,7 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio
                -> ModLocation
                -> NcgImpl statics instr jumpDest
                -> Handle
-               -> UniqSupply
+               -> DUniqSupply
                -> Stream IO RawCmmGroup a
                -> IO a
 nativeCodeGen' logger config modLoc ncgImpl h us cmms
@@ -223,9 +223,9 @@ finishNativeGen :: Instruction instr
                 -> NCGConfig
                 -> ModLocation
                 -> BufHandle
-                -> UniqSupply
+                -> DUniqSupply
                 -> NativeGenAcc statics instr
-                -> IO UniqSupply
+                -> IO DUniqSupply
 finishNativeGen logger config modLoc bufh us ngs
  = withTimingSilent logger (text "NCG") (`seq` ()) $ do
         -- Write debug data and finish
@@ -284,19 +284,19 @@ cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform st
               -> ModLocation
               -> NcgImpl statics instr jumpDest
               -> BufHandle
-              -> UniqSupply
+              -> DUniqSupply
               -> Stream.Stream IO RawCmmGroup a
               -> NativeGenAcc statics instr
-              -> IO (NativeGenAcc statics instr, UniqSupply, a)
+              -> IO (NativeGenAcc statics instr, DUniqSupply, a)
 
 cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs
  = loop us (Stream.runStream cmm_stream) ngs
   where
     ncglabel = text "NCG"
-    loop :: UniqSupply
+    loop :: DUniqSupply
               -> Stream.StreamS IO RawCmmGroup a
               -> NativeGenAcc statics instr
-              -> IO (NativeGenAcc statics instr, UniqSupply, a)
+              -> IO (NativeGenAcc statics instr, DUniqSupply, a)
     loop us s ngs =
       case s of
         Stream.Done a ->
@@ -345,17 +345,17 @@ cmmNativeGens :: forall statics instr jumpDest.
               -> NcgImpl statics instr jumpDest
               -> BufHandle
               -> LabelMap DebugBlock
-              -> UniqSupply
+              -> DUniqSupply
               -> [RawCmmDecl]
               -> NativeGenAcc statics instr
               -> Int
-              -> IO (NativeGenAcc statics instr, UniqSupply)
+              -> IO (NativeGenAcc statics instr, DUniqSupply)
 
 cmmNativeGens logger config ncgImpl h dbgMap = go
   where
-    go :: UniqSupply -> [RawCmmDecl]
+    go :: DUniqSupply -> [RawCmmDecl]
        -> NativeGenAcc statics instr -> Int
-       -> IO (NativeGenAcc statics instr, UniqSupply)
+       -> IO (NativeGenAcc statics instr, DUniqSupply)
 
     go us [] ngs !_ =
         return (ngs, us)
@@ -430,12 +430,12 @@ cmmNativeGen
     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)
     => Logger
     -> NcgImpl statics instr jumpDest
-        -> UniqSupply
+        -> DUniqSupply
         -> DwarfFiles
         -> LabelMap DebugBlock
         -> RawCmmDecl                                   -- ^ the cmm to generate code for
         -> Int                                          -- ^ sequence number of this top thing
-        -> IO   ( UniqSupply
+        -> IO   ( DUniqSupply
                 , DwarfFiles
                 , [NatCmmDecl statics instr]                -- native code
                 , [CLabel]                                  -- things imported by this cmm
@@ -475,7 +475,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
         -- generate native code from cmm
         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
                 {-# SCC "genMachCode" #-}
-                initUs us $ genMachCode config
+                runUniqueDSM us $ genMachCode config
                                         (cmmTopCodeGen ncgImpl)
                                         fileIds dbgMap opt_cmm cmmCfg
 
@@ -493,7 +493,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                                 else Nothing
         let (withLiveness, usLive) =
                 {-# SCC "regLiveness" #-}
-                initUs usGen
+                runUniqueDSM usGen
                         $ mapM (cmmTopLiveness livenessCfg platform) native
 
         putDumpFileMaybe logger
@@ -515,7 +515,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                 -- do the graph coloring register allocation
                 let ((alloced, maybe_more_stack, regAllocStats), usAlloc)
                         = {-# SCC "RegAlloc-color" #-}
-                          initUs usLive
+                          runUniqueDSM usLive
                           $ Color.regAlloc
                                 config
                                 alloc_regs
@@ -525,13 +525,13 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                                 livenessCfg
 
                 let ((alloced', stack_updt_blks), usAlloc')
-                        = initUs usAlloc $
-                                case maybe_more_stack of
-                                Nothing     -> return (alloced, [])
-                                Just amount -> do
-                                    (alloced',stack_updt_blks) <- unzip <$>
-                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
-                                    return (alloced', concat stack_updt_blks )
+                        = runUniqueDSM usAlloc $
+                            case maybe_more_stack of
+                            Nothing     -> return (alloced, [])
+                            Just amount -> do
+                                (alloced',stack_updt_blks) <- unzip <$>
+                                            (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
+                                return (alloced', concat stack_updt_blks )
 
 
                 -- dump out what happened during register allocation
@@ -562,6 +562,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                         , [], stack_updt_blks)
 
           else do
+
                 -- do linear register allocation
                 let reg_alloc proc = do
                        (alloced, maybe_more_stack, ra_stats) <-
@@ -575,7 +576,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
 
                 let ((alloced, regAllocStats, stack_updt_blks), usAlloc)
                         = {-# SCC "RegAlloc-linear" #-}
-                          initUs usLive
+                          runUniqueDSM usLive
                           $ liftM unzip3
                           $ mapM reg_alloc withLiveness
 
@@ -647,7 +648,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
         -- sequenced :: [NatCmmDecl statics instr]
         let (sequenced, us_seq) =
                         {-# SCC "sequenceBlocks" #-}
-                        initUs usAlloc $ mapM (BlockLayout.sequenceTop
+                        runUniqueDSM usAlloc $ mapM (BlockLayout.sequenceTop
                                 ncgImpl optimizedCFG)
                             shorted
 
@@ -919,7 +920,7 @@ genMachCode
         -> LabelMap DebugBlock
         -> RawCmmDecl
         -> CFG
-        -> UniqSM
+        -> UniqDSM
                 ( [NatCmmDecl statics instr]
                 , [CLabel]
                 , DwarfFiles
@@ -927,15 +928,16 @@ genMachCode
                 )
 
 genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
-  = do  { initial_us <- getUniqueSupplyM
-        ; let initial_st           = mkNatM_State initial_us 0 config
-                                                  fileIds dbgMap cmm_cfg
-              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
-              final_delta          = natm_delta final_st
-              final_imports        = natm_imports final_st
-              final_cfg            = natm_cfg final_st
-        ; if   final_delta == 0
-          then return (new_tops, final_imports
-                      , natm_fileid final_st, final_cfg)
-          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
-    }
+  = UDSM $ \initial_us -> do
+      { let initial_st           = mkNatM_State initial_us 0 config
+                                                fileIds dbgMap cmm_cfg
+            (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+            final_delta          = natm_delta final_st
+            final_imports        = natm_imports final_st
+            final_cfg            = natm_cfg final_st
+      ; if   final_delta == 0
+        then DUniqResult
+              (new_tops, final_imports
+                , natm_fileid final_st, final_cfg) (natm_us final_st)
+        else DUniqResult (pprPanic "genMachCode: nonzero final delta" (int final_delta)) undefined
+      }