[Git][ghc/ghc][wip/romes/12935] UniqDSM det uniques + use in Cmm.Info
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu Jun 27 17:31:06 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
2a99624a by Rodrigo Mesquita at 2024-06-27T18:30:53+01:00
UniqDSM det uniques + use in Cmm.Info
- - - - -
3 changed files:
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
Changes:
=====================================
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.Cmm.UniqueRenamer
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,17 @@ mkEmptyContInfoTable info_lbl
cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
-> IO (Stream IO RawCmmGroup a)
cmmToRawCmm logger profile cmms
- = do {
+ = do { detUqSupply <- newIORef (DUS 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
+ let (a, us) = runUniqueDSM 'i' nextUq $ concatMapM (mkInfoTable profile) cmm
+ writeIORef detUqSupply us
+ return a
; return (Stream.mapM do_one cmms)
}
@@ -114,7 +116,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 +179,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 +220,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 +340,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 +414,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/Pipeline.hs
=====================================
@@ -359,7 +359,6 @@ 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/UniqueRenamer.hs
=====================================
@@ -1,11 +1,14 @@
-{-# LANGUAGE LambdaCase, UnicodeSyntax #-}
+{-# LANGUAGE LambdaCase, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}
module GHC.Cmm.UniqueRenamer
( detRenameUniques
+ , UniqDSM, runUniqueDSM
+ , DUniqSupply(..), getUniqueDSM
-- Careful! Not for general use!
, DetUniqFM, emptyDetUFM)
where
+import Data.Bits
import Prelude
import Control.Monad.Trans.State
import GHC.Word
@@ -50,6 +53,7 @@ instance Outputable DetUniqFM where
ppr mapping $$
text "supply:" Outputable.<> ppr supply
+-- ToDo: Use ReaderT UniqDSM instead of this?
type DetRnM = State DetUniqFM
emptyDetUFM :: DetUniqFM
@@ -271,3 +275,54 @@ instance (Ord a, UniqRenamable a) => UniqRenamable (S.Set a) where
panicMapKeysNotInjective :: a -> b -> c
panicMapKeysNotInjective _ _ = error "this should be impossible because the function which maps keys should be injective"
+--------------------------------------------------------------------------------
+-- UniqDSM (ToDo: For this to make sense in this module, rename the module to
+-- something like GHC.Cmm.UniqueDeterminism). Write notes....
+
+-- todo: Do I need to use the one-shot state monad trick? Probably yes.
+
+-- check: UniqSM is only used before Cmm (grep for it), afterwards only UniqDSM is used.
+
+-- todo: use UniqSM for UniqRenamable? We've basically re-implemented this logic
+-- there, but without the unboxing it feels? Maybe not, since we carry the
+-- mappings too.
+
+newtype DUniqSupply = DUS Word64 -- supply uniques iteratively
+type DUniqResult result = (# result, DUniqSupply #)
+
+pattern DUniqResult :: a -> b -> (# a, b #)
+pattern DUniqResult x y = (# x, y #)
+{-# COMPLETE DUniqResult #-}
+
+-- | A monad which just gives the ability to obtain 'Unique's deterministically.
+-- There's no splitting.
+newtype UniqDSM result = UDSM { unUDSM :: Word64 {- tag -} -> DUniqSupply -> DUniqResult result }
+ deriving Functor
+
+instance Monad UniqDSM where
+ (>>=) (UDSM f) cont = UDSM $ \tag us0 -> case f tag us0 of
+ DUniqResult result us1 -> unUDSM (cont result) tag us1
+ (>>) = (*>)
+ {-# INLINE (>>=) #-}
+ {-# INLINE (>>) #-}
+
+instance Applicative UniqDSM where
+ pure result = UDSM (\_tag us -> DUniqResult result us)
+ (UDSM f) <*> (UDSM x) = UDSM $ \tag us0 -> case f tag us0 of
+ DUniqResult ff us1 -> case x tag us1 of
+ DUniqResult xx us2 -> DUniqResult (ff xx) us2
+ (*>) (UDSM expr) (UDSM cont) = UDSM $ \tag us0 -> case expr tag us0 of
+ DUniqResult _ us1 -> cont tag us1
+ {-# INLINE pure #-}
+ {-# INLINE (*>) #-}
+
+getUniqueDSM :: UniqDSM Unique
+getUniqueDSM = UDSM (\tag (DUS us0) -> DUniqResult (mkUniqueGrimily $ tag .|. us0) (DUS $ us0+1))
+
+runUniqueDSM :: Char {- tag -} -> DUniqSupply {- first unique -}
+ -> UniqDSM a -> (a, DUniqSupply)
+runUniqueDSM c firstUniq (UDSM f) =
+ let !tag = mkTag c
+ in case f tag firstUniq of
+ DUniqResult uq us -> (uq, us)
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a99624aa58865427a53d8ac47ae64a6e61749ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2a99624aa58865427a53d8ac47ae64a6e61749ad
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/20240627/529427f6/attachment-0001.html>
More information about the ghc-commits
mailing list