[Git][ghc/ghc][wip/romes/12935] 4 commits: determinism: DCmmGroup vs CmmGroup
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed Sep 18 18:16:48 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
0a5c2dac by Rodrigo Mesquita at 2024-09-18T19:16:08+01:00
determinism: DCmmGroup vs CmmGroup
Part of our strategy in producing deterministic objects, namely,
renaming all Cmm uniques in order, depend on the object code produced
having a deterministic order (say, A_closure always comes before
B_closure).
However, the use of LabelMaps in the Cmm representation invalidated this
requirement because the LabelMaps elements would already be in a
non-deterministic order (due to the original uniques), and the renaming
in sequence wouldn't work because of that non-deterministic order.
Therefore, we now start off with lists in CmmGroup (which preserve the
original order), and convert them into LabelMaps (for performance in the
code generator) after the uniques of the list elements have been
renamed.
See Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] and #12935.
Co-authored-by: Matthew Pickering <matthewtpickering at gmail.com>
- - - - -
475d1f2e by Rodrigo Mesquita at 2024-09-18T19:16:22+01:00
determinism: Don't print unique in pprFullName
This unique was leaking as part of the profiling description in info
tables when profiling was enabled, despite not providing information
relevant to the profile.
- - - - -
5af98c82 by Rodrigo Mesquita at 2024-09-18T19:16:22+01:00
determinism: UDFM for distinct-constructor-tables
In order to produce deterministic objects when compiling with
-distinct-constructor-tables, we also have to update the data
constructor map to be backed by a deterministic unique map (UDFM) rather
than a non-deterministic one (UniqMap).
- - - - -
ed43ad42 by Rodrigo Mesquita at 2024-09-18T19:16:22+01:00
determinism: InfoTableMap uniques in generateCgIPEStub
Fixes object determinism when using -finfo-table-map
Make sure to also deterministically rename the IPE map (as per Note
[Renaming uniques deterministically]), and to use a deterministic unique
supply when creating new labels for the IPE information to guarantee
deterministic objects when IPE information is requested.
Note that the Cmm group produced in generateCgIPEStub must /not/ be
renamed because renaming uniques is not idempotent, and the references
to the previously renamed code in the IPE Cmm group would be renamed
twice and become invalid references to non-existent symbols.
We do need to det-rename the InfoTableMap that is created in the
conversion from Core to Stg. This is not a problem since that map won't
refer any already renamed names (since it was created before the
renaming).
- - - - -
23 changed files:
- compiler/GHC/Cmm.hs
- compiler/GHC/Cmm/Dataflow/Graph.hs
- compiler/GHC/Cmm/Graph.hs
- compiler/GHC/Cmm/LayoutStack.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/ThreadSanitizer.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/CgUtils.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prof.hs
- compiler/GHC/StgToCmm/Utils.hs
- compiler/GHC/Types/IPE.hs
- compiler/GHC/Types/Name.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Utils/Outputable.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
Changes:
=====================================
compiler/GHC/Cmm.hs
=====================================
@@ -12,22 +12,28 @@
module GHC.Cmm (
-- * Cmm top-level datatypes
+ DCmmGroup,
CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
- CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
- CmmDataDecl, cmmDataDeclCmmDecl,
- CmmGraph, GenCmmGraph(..),
+ CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+ CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph,
+ CmmGraph, GenCmmGraph, GenGenCmmGraph(..),
toBlockMap, revPostorder, toBlockList,
CmmBlock, RawCmmDecl,
Section(..), SectionType(..),
GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
SectionProtection(..), sectionProtection,
+ DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph,
+
-- ** Blocks containing lists
GenBasicBlock(..), blockId,
ListGraph(..), pprBBlock,
-- * Info Tables
- CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+ GenCmmTopInfo(..)
+ , DCmmTopInfo
+ , CmmTopInfo
+ , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD,
ClosureTypeInfo(..),
ProfilingInfo(..), ConstrDescription,
@@ -74,6 +80,8 @@ import qualified Data.ByteString as BS
type CmmProgram = [CmmGroup]
type GenCmmGroup d h g = [GenCmmDecl d h g]
+-- | Cmm group after STG generation
+type DCmmGroup = GenCmmGroup CmmStatics DCmmTopInfo DCmmGraph
-- | Cmm group before SRT generation
type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
-- | Cmm group with SRTs
@@ -117,6 +125,7 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
=> OutputableP Platform (GenCmmDecl d info i) where
pdoc = pprTop
+type DCmmDecl = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
type CmmDataDecl = GenCmmDataDecl CmmStatics
@@ -139,7 +148,11 @@ type RawCmmDecl
-----------------------------------------------------------------------------
type CmmGraph = GenCmmGraph CmmNode
-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type DCmmGraph = GenGenCmmGraph DWrap CmmNode
+
+type GenCmmGraph n = GenGenCmmGraph LabelMap n
+
+data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C }
type CmmBlock = Block CmmNode C C
instance OutputableP Platform CmmGraph where
@@ -171,8 +184,16 @@ toBlockList g = mapElems $ toBlockMap g
-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains
-- the extra info (beyond the executable code) that belongs to that CmmDecl.
-data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
- , stack_info :: CmmStackInfo }
+data GenCmmTopInfo f = TopInfo { info_tbls :: f CmmInfoTable
+ , stack_info :: CmmStackInfo }
+
+newtype DWrap a = DWrap [(BlockId, a)]
+
+unDeterm :: DWrap a -> [(BlockId, a)]
+unDeterm (DWrap f) = f
+
+type DCmmTopInfo = GenCmmTopInfo DWrap
+type CmmTopInfo = GenCmmTopInfo LabelMap
instance OutputableP Platform CmmTopInfo where
pdoc = pprTopInfo
@@ -182,7 +203,12 @@ pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
vcat [text "info_tbls: " <> pdoc platform info_tbl,
text "stack_info: " <> ppr stack_info]
-topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
+topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of
+ DWrap xs -> lookup (g_entry g) xs
+topInfoTableD _ = Nothing
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
@@ -237,6 +263,7 @@ data ProfilingInfo
= NoProfilingInfo
| ProfilingInfo ByteString ByteString -- closure_type, closure_desc
deriving (Eq, Ord)
+
-----------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
@@ -328,6 +355,61 @@ 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 structure, 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 structure, 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.
+
+We prefer using the renamed LabelMap rather than the list in the rest of the
+code generation because it is much more efficient than lists for the needs of
+the code generator.
+-}
+
+-- 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
=====================================
@@ -278,6 +278,7 @@ import GHC.Parser.Lexer
import GHC.Parser.Errors.Types
import GHC.Parser.Errors.Ppr
+import GHC.Types.Unique.DSM
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
import GHC.Unit.Module
@@ -1575,7 +1576,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,11 +1596,17 @@ 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
- ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info
+ -- We need to pass a deterministic unique supply to generate IPE
+ -- symbols deterministically. The symbols created by
+ -- emitIpeBufferListNode must all be local to the object (see
+ -- comment on its definition). If the symbols weren't local, using a
+ -- counter starting from zero for every Cmm file would cause
+ -- conflicts when compiling more than one Cmm file together.
+ (_, cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info (initDUniqSupply 'P' 0)
return (cmm ++ cmm2, used_info)
(cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode
(warnings,errors) = getPsMessages pst
=====================================
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
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
module GHC.Cmm.UniqueRenamer
( detRenameCmmGroup
+ , detRenameIPEMap
, MonadGetUnique(..)
-- Careful! Not for general use!
@@ -10,7 +11,7 @@ module GHC.Cmm.UniqueRenamer
)
where
-import Prelude
+import GHC.Prelude
import GHC.Utils.Monad.State.Strict
import Data.Tuple (swap)
import GHC.Word
@@ -22,12 +23,13 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Switch
import GHC.Types.Unique
import GHC.Types.Unique.FM
+import GHC.Types.Unique.DFM
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
-
+import GHC.Types.IPE
{-
Note [Renaming uniques deterministically]
@@ -104,6 +106,12 @@ detRenameId i
| isExternalName (varName i) = return i
| otherwise = setIdUnique i <$> renameDetUniq (getUnique i)
+-- | Similar to `detRenameId`, but for `Name`.
+detRenameName :: Name -> DetRnM Name
+detRenameName n
+ | isExternalName n = return n
+ | otherwise = setNameUnique n <$> renameDetUniq (getUnique n)
+
detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup)
detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm)
where
@@ -251,3 +259,19 @@ detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm
detRenameMaybe f (Just x) = Just <$> f x
detRenamePair f g (a, b) = (,) <$> f a <*> g b
+
+detRenameIPEMap :: DetUniqFM -> InfoTableProvMap -> (DetUniqFM, InfoTableProvMap)
+detRenameIPEMap dufm InfoTableProvMap{ provDC, provClosure, provInfoTables } =
+ (dufm2, InfoTableProvMap { provDC, provClosure = cm, provInfoTables })
+ where
+ (cm, dufm2) = runState (detRenameClosureMap provClosure) dufm
+
+ detRenameClosureMap :: ClosureMap -> DetRnM ClosureMap
+ detRenameClosureMap m =
+ -- `eltsUDFM` preserves the deterministic order, but it doesn't matter
+ -- since we will rename all uniques deterministically, thus the
+ -- reconstructed map will necessarily be deterministic too.
+ listToUDFM <$> mapM (\(n,r) -> do
+ n' <- detRenameName n
+ return (n', (n', r))
+ ) (eltsUDFM m)
=====================================
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)
@@ -195,6 +195,7 @@ generateCgIPEStub
:: HscEnv
-> Module
-> InfoTableProvMap
+ -- ^ If the CmmInfoTables map refer Cmm symbols which were deterministically renamed, the info table provenance map must also be accordingly renamed.
-> ( NonCaffySet
, ModuleLFInfos
, Map CmmInfoTable (Maybe IpeSourceLocation)
@@ -209,11 +210,22 @@ generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesW
cmm_cfg = initCmmConfig dflags
cgState <- liftIO initC
- -- Yield Cmm for Info Table Provenance Entries (IPEs)
- 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')
+ -- NB: For determinism, don't use DetUniqFM to rename the IPE Cmm because
+ -- detRenameCmm isn't idempotent and this Cmm references symbols in the rest
+ -- of the code! Instead, make sure all labels generated for IPE related code
+ -- sources uniques from the DUniqSupply gotten from CgStream (see its use in
+ -- initInfoTableProv/emitIpeBufferListNode).
+ (mIpeStub, ipeCmmGroup) <- liftEff $ UDSMT $ \dus -> do
- (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup
+ -- Yield Cmm for Info Table Provenance Entries (IPEs)
+ let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}
+ (((mIpeStub, dus'), ipeCmmGroup), _) =
+ runC (initStgToCmmConfig dflags this_mod) fstate cgState $
+ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv' dus)
+
+ return ((mIpeStub, ipeCmmGroup), dus')
+
+ (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup)
Stream.yield ipeCmmGroupSRTs
ipeStub <-
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -215,6 +215,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)
import Data.Bifunctor
@@ -2121,12 +2121,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)
@@ -2211,11 +2213,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 :: CgStream CmmGroup ModuleLFInfos
+ let cmm_stream :: CgStream 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
@@ -2237,11 +2239,21 @@ doCodeGen hsc_env this_mod denv data_tycons
pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos
pipeline_stream = do
- ((mod_srt_info, ipes, ipe_stats), lf_infos) <-
+ ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-
{-# SCC "cmmPipeline" #-}
Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1
+
let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)
- cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats)
+
+ -- denv::InfoTableProvMap refers to symbols that no longer exist
+ -- if -fobject-determinism is on, since it was created before the
+ -- Cmm was renamed. Update all the symbols by renaming them with
+ -- the renaming map in that case.
+ (_drn, rn_denv)
+ | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv
+ | otherwise = (detRnEnv, denv)
+
+ cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats)
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
@@ -23,7 +24,6 @@ import Control.Monad (when)
import Control.Monad.Trans.Reader
import GHC.Utils.Monad.State.Strict
import Control.Monad.Trans.Class
-import GHC.Types.Unique.Map
import GHC.Types.SrcLoc
import Control.Applicative
import qualified Data.List.NonEmpty as NE
@@ -153,7 +153,7 @@ recordStgIdPosition id best_span ss = do
--Useful for debugging why a certain Id gets given a certain span
--pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss)
- lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) })
+ lift $ modify (\env -> env { provClosure = addToUDFM (provClosure env) (idName id) (idName id, (idType id, mbspan)) })
numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber
-- Unboxed tuples and sums do not allocate so they
@@ -166,13 +166,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
=====================================
@@ -44,6 +44,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
@@ -61,7 +62,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
@@ -82,7 +82,7 @@ codeGen :: Logger
-- 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
@@ -137,7 +137,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
@@ -158,7 +158,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
=====================================
@@ -29,6 +29,7 @@ import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Utils.Panic
+import GHC.Cmm.Dataflow.Label
import GHC.Data.Stream (Stream)
import GHC.Types.Unique.DSM (UniqDSMT)
@@ -150,7 +151,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/InfoTableProv.hs
=====================================
@@ -13,6 +13,7 @@ import GHC.IO (unsafePerformIO)
import GHC.Prelude
import GHC.Platform
import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
+import GHC.Types.Unique.DSM
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..))
@@ -70,16 +71,26 @@ construction.
emitIpeBufferListNode ::
Module
-> [InfoProvEnt]
- -> FCode ()
-emitIpeBufferListNode _ [] = return ()
-emitIpeBufferListNode this_mod ents = do
+ -> DUniqSupply -- ^ Symbols created source uniques deterministically
+ -- All uniques must be created from this supply.
+ -- NB: If you are creating a new symbol within this function,
+ -- make sure it is local only (as in not `externallyVisibleCLabel`).
+ -- If you need it to be global, reconsider the comment on the
+ -- call of emitIpeBufferListNode in Cmm.Parser.
+ -> FCode DUniqSupply
+emitIpeBufferListNode _ [] dus = return dus
+emitIpeBufferListNode this_mod ents dus0 = do
cfg <- getStgToCmmConfig
- tables_lbl <- mkStringLitLabel <$> newUnique
- strings_lbl <- mkStringLitLabel <$> newUnique
- entries_lbl <- mkStringLitLabel <$> newUnique
+ let (u1, dus1) = takeUniqueFromDSupply dus0
+ (u2, dus2) = takeUniqueFromDSupply dus1
+ (u3, dus3) = takeUniqueFromDSupply dus2
- let ctx = stgToCmmContext cfg
+ tables_lbl = mkStringLitLabel u1
+ strings_lbl = mkStringLitLabel u2
+ entries_lbl = mkStringLitLabel u3
+
+ ctx = stgToCmmContext cfg
platform = stgToCmmPlatform cfg
int n = mkIntCLit platform n
@@ -166,6 +177,8 @@ emitIpeBufferListNode this_mod ents = do
(Section Data ipe_buffer_lbl)
(CmmStaticsRaw ipe_buffer_lbl ipe_buffer_node)
+ return dus3
+
-- | Emit the fields of an IpeBufferEntry struct for each entry in a given list.
toIpeBufferEntries ::
ByteOrder -- ^ Byte order to write the data in
=====================================
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/Prof.hs
=====================================
@@ -43,6 +43,7 @@ import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
+import GHC.Types.Unique.DSM
import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.ForeignStubs
@@ -279,8 +280,8 @@ sizeof_ccs_words platform
-- Note that the stats passed to this function will (rather, should) only ever
-- contain stats for skipped STACK info tables accumulated in
-- 'generateCgIPEStub'.
-initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> FCode (Maybe (IPEStats, CStub))
-initInfoTableProv stats infos itmap
+initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> DUniqSupply -> FCode (Maybe (IPEStats, CStub), DUniqSupply)
+initInfoTableProv stats infos itmap dus
= do
cfg <- getStgToCmmConfig
let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos
@@ -288,13 +289,13 @@ initInfoTableProv stats infos itmap
platform = stgToCmmPlatform cfg
this_mod = stgToCmmThisModule cfg
case ents of
- [] -> return Nothing
+ [] -> return (Nothing, dus)
_ -> do
-- Emit IPE buffer
- emitIpeBufferListNode this_mod ents
+ dus' <- emitIpeBufferListNode this_mod ents dus
-- Create the C stub which initialises the IPE map
- return (Just (stats', ipInitCode info_table platform this_mod))
+ return (Just (stats', ipInitCode info_table platform this_mod), dus')
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
=====================================
compiler/GHC/StgToCmm/Utils.hs
=====================================
@@ -86,11 +86,10 @@ import GHC.Types.IPE
import qualified Data.Map as M
import Data.List (sortBy)
import Data.Ord
-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 +672,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])
@@ -686,7 +685,7 @@ convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTable
tyString = renderWithContext defaultSDocContext . ppr
lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)
- lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of
+ lookupClosureMap = case hasHaskellName cl >>= fmap snd . lookupUDFM denv of
Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan))
Nothing -> Nothing
@@ -694,7 +693,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,7 +13,7 @@ import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Core.DataCon
-import GHC.Types.Unique.Map
+import GHC.Types.Unique.DFM
import GHC.Core.Type
import Data.List.NonEmpty
import GHC.Cmm.CLabel (CLabel)
@@ -25,8 +25,8 @@ type IpeSourceLocation = (RealSrcSpan, LexicalFastString)
-- | A map from a 'Name' to the best approximate source position that
-- name arose from.
-type ClosureMap = UniqMap Name -- The binding
- (Type, Maybe IpeSourceLocation)
+type ClosureMap = UniqDFM Name -- The binding
+ (Name, (Type, Maybe IpeSourceLocation))
-- The best approximate source position.
-- (rendered type, source position, source note
-- label)
@@ -38,7 +38,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 +49,4 @@ data InfoTableProvMap = InfoTableProvMap
}
emptyInfoTableProvMap :: InfoTableProvMap
-emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty
+emptyInfoTableProvMap = InfoTableProvMap emptyUDFM emptyUDFM 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 and 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])
@@ -1200,6 +1204,9 @@ instance OutputableP env a => OutputableP env [a] where
instance OutputableP env a => OutputableP env (Maybe a) where
pdoc env xs = ppr (fmap (pdoc env) xs)
+instance OutputableP env () where
+ pdoc _ _ = ppr ()
+
instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where
pdoc env (a,b) = ppr (pdoc env a, pdoc env b)
=====================================
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
=====================================
@@ -122,7 +122,7 @@ slurpCmm hsc_env filename = runHsc hsc_env $ do
$ parseCmmFile cmmpConfig cmm_mod home_unit filename
let msgs = warns `unionMessages` errs
return (GhcPsMessage <$> msgs, cmm)
- return cmm
+ return (removeDeterm cmm)
collectAll :: Monad m => Stream m a b -> m ([a], b)
collectAll = gobble . runStream
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b1fc47dfc8ec3abbbba36bc6dfba2ff1824cf69...ed43ad4297715de55a9f7e3a9be4017a2f55f1a2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4b1fc47dfc8ec3abbbba36bc6dfba2ff1824cf69...ed43ad4297715de55a9f7e3a9be4017a2f55f1a2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240918/76c32a16/attachment-0001.html>
More information about the ghc-commits
mailing list