[Git][ghc/ghc][wip/romes/12935] 3 commits: UniqDSMT...
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Tue Sep 10 14:49:00 UTC 2024
Rodrigo Mesquita pushed to branch wip/romes/12935 at Glasgow Haskell Compiler / GHC
Commits:
44c907b8 by Rodrigo Mesquita at 2024-09-09T11:41:38+01:00
UniqDSMT...
- - - - -
2ed99824 by Rodrigo Mesquita at 2024-09-09T11:41:53+01:00
liftEff hoistEff
- - - - -
90b8bdb0 by Rodrigo Mesquita at 2024-09-10T15:48:42+01:00
CgStream
Revert "Very bad..."
This reverts commit 1d6c826927df8abfd18649baa5d772bbbd3721df.
Note tweaks
Reapply "Very bad..."
This reverts commit 09f3a4ec6c78024e235c8f9c2488398b719a519f.
GODO
- - - - -
15 changed files:
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Wasm.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/Data/Stream.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/GenerateCgIPEStub.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/StgToCmm.hs
- compiler/GHC/StgToCmm/CgUtils.hs
- compiler/GHC/StgToCmm/Types.hs
- compiler/GHC/Types/Unique/DSM.hs
- compiler/GHC/Types/Unique/Supply.hs
Changes:
=====================================
compiler/GHC/Cmm/Info.hs
=====================================
@@ -36,9 +36,10 @@ import GHC.Prelude
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
+import GHC.StgToCmm.CgUtils (CgStream)
import GHC.Runtime.Heap.Layout
import GHC.Data.Bitmap
-import GHC.Data.Stream (Stream)
+import GHC.Data.Stream (liftEff)
import qualified GHC.Data.Stream as Stream
import GHC.Cmm.Dataflow.Label
@@ -54,7 +55,7 @@ import GHC.Utils.Outputable
import GHC.Types.Unique.DSM
import Data.ByteString (ByteString)
-import Data.IORef
+import qualified Control.Monad.Trans.State.Strict as T
-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
@@ -65,26 +66,23 @@ mkEmptyContInfoTable info_lbl
, cit_srt = Nothing
, cit_clo = Nothing }
-cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
- -> IO (Stream IO RawCmmGroup a)
+cmmToRawCmm :: Logger -> Profile -> CgStream CmmGroupSRTs a
+ -> IO (CgStream RawCmmGroup a)
cmmToRawCmm logger profile cmms
- = do { detUqSupply <- newIORef (initDUniqSupply 'i' 1)
- ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
+ = do { let do_one :: [CmmDeclSRTs] -> UniqDSMT IO [RawCmmDecl]
do_one cmm = do
-- NB. strictness fixes a space leak. DO NOT REMOVE.
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
+ us <- UDSMT T.get
+ let (a, us') = runUniqueDSM us $
+ concatMapM (mkInfoTable profile) cmm
+ UDSMT (T.put us')
return a
- ; return (Stream.mapM do_one cmms)
+ ; return $ do
+ -- Override the unique supply tag to 'i'
+ _ <- liftEff $ UDSMT (T.modify @IO (newTagDUniqSupply 'i'))
+ Stream.mapM do_one cmms
}
=====================================
compiler/GHC/Cmm/Pipeline.hs
=====================================
@@ -44,12 +44,12 @@ cmmPipeline
:: Logger
-> CmmConfig
-> ModuleSRTInfo -- Info about SRTs generated so far
- -> DUniqSupply
-> CmmGroup -- Input C-- with Procedures
- -> IO (ModuleSRTInfo, DUniqSupply, CmmGroupSRTs) -- Output CPS transformed C--
+ -> DUniqSupply
+ -> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply) -- Output CPS transformed C--
-cmmPipeline logger cmm_config srtInfo dus0 prog = do
- let forceRes (info, us, group) = info `seq` us `seq` foldr seq () group
+cmmPipeline logger cmm_config srtInfo prog dus0 = do
+ let forceRes ((info, group), us) = info `seq` us `seq` foldr seq () group
let platform = cmmPlatform cmm_config
withTimingSilent logger (text "Cmm pipeline") forceRes $ do
(dus1, prog') <- {-# SCC "tops" #-} mapAccumLM (cpsTop logger platform cmm_config) dus0 prog
@@ -57,7 +57,7 @@ cmmPipeline logger cmm_config srtInfo dus0 prog = do
(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, dus, cmms)
+ return ((srtInfo, cmms), dus)
-- | The Cmm pipeline for a single 'CmmDecl'. Returns:
--
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -116,7 +116,8 @@ import GHC.Utils.Constants (debugIsOn)
import GHC.Data.FastString
import GHC.Types.Unique.Set
import GHC.Unit
-import GHC.Data.Stream (Stream)
+import GHC.StgToCmm.CgUtils (CgStream)
+import GHC.Data.Stream (liftIO)
import qualified GHC.Data.Stream as Stream
import GHC.Settings
@@ -129,14 +130,14 @@ import System.IO
import System.Directory ( getCurrentDirectory )
--------------------
-nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> DUniqSupply
- -> Stream IO RawCmmGroup a
- -> IO a
-nativeCodeGen logger ts config modLoc h us cmms
+nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle
+ -> CgStream RawCmmGroup a
+ -> UniqDSMT IO a
+nativeCodeGen logger ts config modLoc h cmms
= let platform = ncgPlatform config
nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
- => NcgImpl statics instr jumpDest -> IO a
- nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms
+ => NcgImpl statics instr jumpDest -> UniqDSMT IO a
+ nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h cmms
in case platformArch platform of
ArchX86 -> nCG' (X86.ncgX86 config)
ArchX86_64 -> nCG' (X86.ncgX86_64 config)
@@ -152,7 +153,7 @@ nativeCodeGen logger ts config modLoc h us cmms
ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
- ArchWasm32 -> Wasm32.ncgWasm config logger platform ts us modLoc h cmms
+ ArchWasm32 -> Wasm32.ncgWasm config logger platform ts modLoc h cmms
-- | Data accumulated during code generation. Mostly about statistics,
-- but also collects debug data for DWARF generation.
@@ -203,19 +204,17 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio
-> ModLocation
-> NcgImpl statics instr jumpDest
-> Handle
- -> DUniqSupply
- -> Stream IO RawCmmGroup a
- -> IO a
-nativeCodeGen' logger config modLoc ncgImpl h us cmms
+ -> CgStream RawCmmGroup a
+ -> UniqDSMT IO a
+nativeCodeGen' logger config modLoc ncgImpl h cmms
= do
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
- bufh <- newBufHandle h
+ bufh <- liftIO $ newBufHandle h
let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
- (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us
- cmms ngs0
- _ <- finishNativeGen logger config modLoc bufh us' ngs
+ (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0
+ _ <- finishNativeGen logger config modLoc bufh ngs
return a
finishNativeGen :: Instruction instr
@@ -223,20 +222,20 @@ finishNativeGen :: Instruction instr
-> NCGConfig
-> ModLocation
-> BufHandle
- -> DUniqSupply
-> NativeGenAcc statics instr
- -> IO DUniqSupply
-finishNativeGen logger config modLoc bufh us ngs
+ -> UniqDSMT IO ()
+finishNativeGen logger config modLoc bufh ngs
= withTimingSilent logger (text "NCG") (`seq` ()) $ do
- -- Write debug data and finish
- us' <- if not (ncgDwarfEnabled config)
- then return us
- else do
- compPath <- getCurrentDirectory
- let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)
- (dwarf_s, _) = dwarfGen compPath config modLoc us (ngs_debug ngs)
- emitNativeCode logger config bufh dwarf_h dwarf_s
- return us'
+ -- Write debug data and finish
+ if not (ncgDwarfEnabled config)
+ then return ()
+ else withDUS $ \us -> do
+ compPath <- getCurrentDirectory
+ let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)
+ (dwarf_s, _) = dwarfGen compPath config modLoc us (ngs_debug ngs)
+ emitNativeCode logger config bufh dwarf_h dwarf_s
+ return ((), us')
+ liftIO $ do
-- dump global NCG stats for graph coloring allocator
let stats = concat (ngs_colorStats ngs)
@@ -272,7 +271,7 @@ finishNativeGen logger config modLoc bufh us ngs
bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))
bFlush bufh
- return us'
+ return ()
where
dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)
Opt_D_dump_asm_stats "NCG stats"
@@ -284,20 +283,18 @@ cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform st
-> ModLocation
-> NcgImpl statics instr jumpDest
-> BufHandle
- -> DUniqSupply
- -> Stream.Stream IO RawCmmGroup a
+ -> CgStream RawCmmGroup a
-> NativeGenAcc statics instr
- -> IO (NativeGenAcc statics instr, DUniqSupply, a)
+ -> UniqDSMT IO (NativeGenAcc statics instr, a)
-cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs
- = loop us (Stream.runStream cmm_stream) ngs
+cmmNativeGenStream logger config modLoc ncgImpl h cmm_stream ngs
+ = loop (Stream.runStream cmm_stream) ngs
where
ncglabel = text "NCG"
- loop :: DUniqSupply
- -> Stream.StreamS IO RawCmmGroup a
- -> NativeGenAcc statics instr
- -> IO (NativeGenAcc statics instr, DUniqSupply, a)
- loop us s ngs =
+ loop :: Stream.StreamS (UniqDSMT IO) RawCmmGroup a
+ -> NativeGenAcc statics instr
+ -> UniqDSMT IO (NativeGenAcc statics instr, a)
+ loop s ngs =
case s of
Stream.Done a ->
return (ngs { ngs_imports = reverse $ ngs_imports ngs
@@ -305,35 +302,33 @@ cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs
, ngs_colorStats = reverse $ ngs_colorStats ngs
, ngs_linearStats = reverse $ ngs_linearStats ngs
},
- us,
a)
- Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs
+ Stream.Effect m -> m >>= \cmm_stream' -> loop cmm_stream' ngs
Stream.Yield cmms cmm_stream' -> do
- (us', ngs'') <-
- withTimingSilent logger
- ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
+ ngs'' <-
+ withTimingSilent logger ncglabel (`seq` ()) $ do
-- Generate debug information
let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms
| otherwise = []
dbgMap = debugToMap ndbgs
-- Generate native code
- (ngs',us') <- cmmNativeGens logger config ncgImpl h
- dbgMap us cmms ngs 0
+ ngs' <- withDUS $ cmmNativeGens logger config ncgImpl h
+ dbgMap cmms ngs 0
-- Link native code information into debug blocks
-- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
platform = ncgPlatform config
- unless (null ldbgs) $
+ unless (null ldbgs) $ liftIO $
putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText
(vcat $ map (pdoc platform) ldbgs)
-- Accumulate debug information for emission in finishNativeGen.
let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
- return (us', ngs'')
+ return ngs''
- loop us' cmm_stream' ngs''
+ loop cmm_stream' ngs''
-- | Do native code generation on all these cmms.
@@ -345,22 +340,22 @@ cmmNativeGens :: forall statics instr jumpDest.
-> NcgImpl statics instr jumpDest
-> BufHandle
-> LabelMap DebugBlock
- -> DUniqSupply
-> [RawCmmDecl]
-> NativeGenAcc statics instr
-> Int
+ -> DUniqSupply
-> IO (NativeGenAcc statics instr, DUniqSupply)
cmmNativeGens logger config ncgImpl h dbgMap = go
where
- go :: DUniqSupply -> [RawCmmDecl]
- -> NativeGenAcc statics instr -> Int
+ go :: [RawCmmDecl]
+ -> NativeGenAcc statics instr -> Int -> DUniqSupply
-> IO (NativeGenAcc statics instr, DUniqSupply)
- go us [] ngs !_ =
+ go [] ngs !_ us =
return (ngs, us)
- go us (cmm : cmms) ngs count = do
+ go (cmm : cmms) ngs count us = do
let fileIds = ngs_dwarfFiles ngs
(us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)
<- {-# SCC "cmmNativeGen" #-}
@@ -409,7 +404,7 @@ cmmNativeGens logger config ncgImpl h dbgMap = go
, ngs_dwarfFiles = fileIds'
, ngs_unwinds = ngs_unwinds ngs `mapUnion` unwinds
}
- go us' cmms ngs' (count + 1)
+ go cmms ngs' (count + 1) us'
-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
=====================================
compiler/GHC/CmmToAsm/Wasm.hs
=====================================
@@ -16,7 +16,8 @@ import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Wasm.Asm
import GHC.CmmToAsm.Wasm.FromCmm
import GHC.CmmToAsm.Wasm.Types
-import GHC.Data.Stream (Stream, StreamS (..), runStream)
+import GHC.StgToCmm.CgUtils (CgStream)
+import GHC.Data.Stream (Stream, StreamS (..), runStream, liftIO)
import GHC.Driver.DynFlags
import GHC.Platform
import GHC.Prelude
@@ -32,13 +33,12 @@ ncgWasm ::
Logger ->
Platform ->
ToolSettings ->
- DUniqSupply ->
ModLocation ->
Handle ->
- Stream IO RawCmmGroup a ->
- IO a
-ncgWasm ncg_config logger platform ts us loc h cmms = do
- (r, s) <- streamCmmGroups ncg_config platform us cmms
+ CgStream RawCmmGroup a ->
+ UniqDSMT IO a
+ncgWasm ncg_config logger platform ts loc h cmms = do
+ (r, s) <- streamCmmGroups ncg_config platform cmms
outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
outputWasm $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s
pure r
@@ -46,7 +46,7 @@ ncgWasm ncg_config logger platform ts us loc h cmms = do
-- See Note [WasmTailCall]
do_tail_call = doTailCall ts
- outputWasm builder = do
+ outputWasm builder = liftIO $ do
putDumpFileMaybe
logger
Opt_D_dump_asm
@@ -58,14 +58,16 @@ ncgWasm ncg_config logger platform ts us loc h cmms = do
streamCmmGroups ::
NCGConfig ->
Platform ->
- DUniqSupply ->
- Stream IO RawCmmGroup a ->
- IO (a, WasmCodeGenState 'I32)
-streamCmmGroups ncg_config platform us cmms =
- go (initialWasmCodeGenState platform us) $ runStream cmms
+ CgStream RawCmmGroup a ->
+ UniqDSMT IO (a, WasmCodeGenState 'I32)
+streamCmmGroups ncg_config platform cmms = withDUS $ \us -> do
+ (r,s) <- go (initialWasmCodeGenState platform us) $ runStream cmms
+ return ((r,s), wasmDUniqSupply s)
where
go s (Done r) = pure (r, s)
- go s (Effect m) = m >>= go s
+ go s (Effect m) = do
+ (a, us') <- runUDSMT (wasmDUniqSupply s) m
+ go s{wasmDUniqSupply = us'} a
go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k
where
-- Run the generic cmm optimizations like other NCGs, followed
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -23,10 +23,11 @@ import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Mangler
import GHC.CmmToLlvm.Version
-import GHC.StgToCmm.CgUtils ( fixStgRegisters )
+import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream )
import GHC.Cmm
import GHC.Cmm.Dataflow.Label
+import GHC.Types.Unique.DSM
import GHC.Utils.BufHandle
import GHC.Driver.DynFlags
import GHC.Platform ( platformArch, Arch(..) )
@@ -46,9 +47,11 @@ import System.IO
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: Logger -> LlvmCgConfig -> Handle
- -> Stream.Stream IO RawCmmGroup a
- -> IO a
-llvmCodeGen logger cfg h cmm_stream
+ -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream.
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a
+ -> IO a
+llvmCodeGen logger cfg h dus cmm_stream
= withTiming logger (text "LLVM CodeGen") (const ()) $ do
bufh <- newBufHandle h
@@ -83,21 +86,24 @@ llvmCodeGen logger cfg h cmm_stream
-- run code generation
a <- runLlvm logger cfg llvm_ver bufh $
- llvmCodeGen' cfg cmm_stream
+ llvmCodeGen' cfg dus cmm_stream
bFlush bufh
return a
-llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a
-llvmCodeGen' cfg cmm_stream
+llvmCodeGen' :: LlvmCgConfig
+ -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream.
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a -> LlvmM a
+llvmCodeGen' cfg dus cmm_stream
= do -- Preamble
renderLlvm (llvmHeader cfg) (llvmHeader cfg)
ghcInternalFunctions
cmmMetaLlvmPrelude
-- Procedures
- a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens
+ (a, _) <- runUDSMT dus $ Stream.consume cmm_stream (hoistUDSMT liftIO) (liftUDSMT . llvmGroupLlvmGens)
-- Declare aliases for forward references
decls <- generateExternDecls
=====================================
compiler/GHC/Data/Stream.hs
=====================================
@@ -9,7 +9,7 @@
-- | Monadic streams
module GHC.Data.Stream (
- Stream(..), StreamS(..), runStream, yield, liftIO,
+ Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff,
collect, consume, fromList,
map, mapM, mapAccumL_
) where
@@ -140,3 +140,22 @@ mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str)
go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b
>>= \r' -> return $ Yield r' (go c' f1 h1 p)))
go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)
+
+-- | Lift an effect into the Stream
+liftEff :: Monad m => m b -> Stream m a b
+liftEff eff = Stream $ \_f g -> Effect (g <$> eff)
+
+-- | Hoist the underlying Stream effect
+-- Note this is not very efficience since, just like 'mapAccumL_', it also needs
+-- to traverse and rebuild the whole stream.
+hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b
+hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where
+ hs :: (a -> n r')
+ -> (b -> StreamS n r' r)
+ -> StreamS m a b
+ -> StreamS n r' r
+ hs f g x = case x of
+ Done d -> g d
+ Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r))
+ Effect e -> Effect (h (hs f g <$> e))
+
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -27,6 +27,8 @@ import GHC.Cmm.Lint ( cmmLint )
import GHC.Cmm
import GHC.Cmm.CLabel
+import GHC.StgToCmm.CgUtils (CgStream)
+
import GHC.Driver.DynFlags
import GHC.Driver.Config.Finder ( initFinderOpts )
import GHC.Driver.Config.CmmToAsm ( initNCGConfig )
@@ -37,7 +39,7 @@ import GHC.Driver.Backend
import GHC.Data.OsPath
import qualified GHC.Data.ShortText as ST
-import GHC.Data.Stream ( Stream )
+import GHC.Data.Stream ( liftIO )
import qualified GHC.Data.Stream as Stream
import GHC.Utils.TmpFs
@@ -86,19 +88,21 @@ codeOutput
-> [(ForeignSrcLang, FilePath)]
-- ^ additional files to be compiled with the C compiler
-> Set UnitId -- ^ Dependencies
- -> Stream IO RawCmmGroup a -- Compiled C--
+ -> DUniqSupply -- ^ The deterministic unique supply to run the CgStream.
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a -- ^ Compiled C--
-> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
[(ForeignSrcLang, FilePath)]{-foreign_fps-},
a)
-codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps
+codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps dus0
cmm_stream
=
do {
-- Lint each CmmGroup as it goes past
; let linted_cmm_stream =
if gopt Opt_DoCmmLinting dflags
- then Stream.mapM do_lint cmm_stream
+ then Stream.mapM (liftIO . do_lint) cmm_stream
else cmm_stream
do_lint cmm = withTimingSilent logger
@@ -115,25 +119,26 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
; return cmm
}
- ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)
+ ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a)
final_stream = do
{ a <- linted_cmm_stream
; let stubs = genForeignStubs a
; emitInitializerDecls this_mod stubs
; return (stubs, a) }
+ ; let dus1 = newTagDUniqSupply 'n' dus0
; (stubs, a) <- case backendCodeOutput (backend dflags) of
- NcgCodeOutput -> outputAsm logger dflags this_mod location filenm
+ NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1
final_stream
- ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps
- LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream
+ ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps
+ LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream
JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream
; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
; return (filenm, stubs_exist, foreign_fps, a)
}
-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
-emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()
+emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup ()
emitInitializerDecls this_mod (ForeignStubs _ cstub)
| initializers <- getInitializers cstub
, not $ null initializers =
@@ -161,15 +166,18 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
outputC :: Logger
-> DynFlags
-> FilePath
- -> Stream IO RawCmmGroup a
+ -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a
-> Set UnitId
-> IO a
-outputC logger dflags filenm cmm_stream unit_deps =
+outputC logger dflags filenm dus cmm_stream unit_deps =
withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
let pkg_names = map unitIdString (Set.toAscList unit_deps)
- doOutput filenm $ \ h -> do
- hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
- hPutStr h "#include \"Stg.h\"\n"
+ doOutput filenm $ \ h -> fmap fst $ runUDSMT dus $ do
+ liftIO $ do
+ hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+ hPutStr h "#include \"Stg.h\"\n"
let platform = targetPlatform dflags
writeC cmm = do
let doc = cmmToC platform cmm
@@ -179,7 +187,7 @@ outputC logger dflags filenm cmm_stream unit_deps =
doc
let ctx = initSDocContext dflags PprCode
printSDocLn ctx LeftMode h doc
- Stream.consume cmm_stream id writeC
+ Stream.consume cmm_stream id (liftIO . writeC)
{-
************************************************************************
@@ -194,15 +202,19 @@ outputAsm :: Logger
-> Module
-> ModLocation
-> FilePath
- -> Stream IO RawCmmGroup a
+ -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a
-> IO a
-outputAsm logger dflags this_mod location filenm cmm_stream = do
- let ncg_uniqs = initDUniqSupply 'n' 0
+outputAsm logger dflags this_mod location filenm dus cmm_stream = do
+ -- Update tag of uniques in Stream
debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)
let ncg_config = initNCGConfig dflags this_mod
{-# SCC "OutputAsm" #-} doOutput filenm $
\h -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream
+ fmap fst $
+ runUDSMT dus $
+ nativeCodeGen logger (toolSettings dflags) ncg_config location h cmm_stream
{-
************************************************************************
@@ -212,12 +224,15 @@ outputAsm logger dflags this_mod location filenm cmm_stream = do
************************************************************************
-}
-outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputLlvm logger llvm_config dflags filenm cmm_stream = do
+outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath
+ -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream
+ -- See Note [Deterministic Uniques in the CG]
+ -> CgStream RawCmmGroup a -> IO a
+outputLlvm logger llvm_config dflags filenm dus cmm_stream = do
lcg_config <- initLlvmCgConfig logger llvm_config dflags
{-# SCC "llvm_output" #-} doOutput filenm $
\f -> {-# SCC "llvm_CodeGen" #-}
- llvmCodeGen logger lcg_config f cmm_stream
+ llvmCodeGen logger lcg_config f dus cmm_stream
{-
************************************************************************
@@ -226,7 +241,7 @@ outputLlvm logger llvm_config dflags filenm cmm_stream = do
* *
************************************************************************
-}
-outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
+outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> CgStream RawCmmGroup a -> IO a
outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We should never reach here!"
++ "\nThe JS backend should shortcircuit to StgToJS after Stg."
++ "\nIf you reached this point then you've somehow made it to Cmm!"
=====================================
compiler/GHC/Driver/GenerateCgIPEStub.hs
=====================================
@@ -13,7 +13,7 @@ import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Info.Build (emptySRT)
import GHC.Cmm.Pipeline (cmmPipeline)
-import GHC.Data.Stream (Stream, liftIO)
+import GHC.Data.Stream (liftIO, liftEff)
import qualified GHC.Data.Stream as Stream
import GHC.Driver.Env (hsc_dflags, hsc_logger)
import GHC.Driver.Env.Types (HscEnv)
@@ -28,6 +28,7 @@ import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)
import GHC.StgToCmm.Prof (initInfoTableProv)
import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
import GHC.StgToCmm.Utils
+import GHC.StgToCmm.CgUtils (CgStream)
import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
import GHC.Types.Name.Set (NonCaffySet)
import GHC.Types.Tickish (GenTickish (SourceNote))
@@ -199,11 +200,10 @@ generateCgIPEStub
, ModuleLFInfos
, Map CmmInfoTable (Maybe IpeSourceLocation)
, IPEStats
- , DUniqSupply
, DetUniqFM
)
- -> Stream IO CmmGroupSRTs CmmCgInfos
-generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats, dus, detRnEnv) = do
+ -> CgStream CmmGroupSRTs CmmCgInfos
+generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats, detRnEnv) = do
let dflags = hsc_dflags hsc_env
platform = targetPlatform dflags
logger = hsc_logger hsc_env
@@ -217,7 +217,7 @@ generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesW
(_detRnEnv', rn_ipeCmmGroup) = detRenameCmmGroup detRnEnv ipeCmmGroup
- (_, _, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) dus rn_ipeCmmGroup
+ (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) rn_ipeCmmGroup
Stream.yield ipeCmmGroupSRTs
ipeStub <-
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -61,6 +61,7 @@ import GHC.Core.Type
import GHC.Tc.Types
import GHC.Stg.Syntax
+import GHC.StgToCmm.CgUtils (CgStream)
import GHC.StgToCmm.Types (ModuleLFInfos)
import GHC.StgToCmm.Config
import GHC.Cmm
@@ -150,8 +151,8 @@ data Hooks = Hooks
, createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
, stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))
- , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
- -> IO (Stream IO RawCmmGroup a)))
+ , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a
+ -> IO (CgStream RawCmmGroup a)))
}
{-# DEPRECATED cmmToRawCmmHook "cmmToRawCmmHook is being deprecated. If you do use it in your project, please raise a GHC issue!" #-}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -208,6 +208,7 @@ import GHC.Builtin.Names
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..))
+import GHC.StgToCmm.CgUtils (CgStream)
import GHC.Cmm
import GHC.Cmm.Info.Build
@@ -268,7 +269,6 @@ import GHC.Data.Bag
import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
-import GHC.Data.Stream (Stream)
import GHC.Data.Maybe
import GHC.SysTools (initSysTools)
@@ -301,6 +301,7 @@ import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Cmm.Config (CmmConfig)
+import Data.Bifunctor
{- **********************************************************************
%* *
@@ -1999,7 +2000,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let dump a = do
unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
return a
- rawcmms1 = Stream.mapM dump rawcmms0
+ rawcmms1 = Stream.mapM (liftIO . dump) rawcmms0
let foreign_stubs st = foreign_stubs0
`appendStubC` prof_init
@@ -2008,7 +2009,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
<- {-# SCC "codeOutput" #-}
codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
- foreign_stubs foreign_files dependencies rawcmms1
+ foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1
return ( output_filename, stub_c_exists, foreign_fps
, Just stg_cg_infos, Just cmm_cg_infos)
@@ -2137,9 +2138,9 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
-- Re-ordering here causes breakage when booting with C backend because
-- in C we must declare before use, but SRT algorithm is free to
-- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]
- cmmgroup <- concat . snd <$>
+ ((_,dus1), cmmgroup) <- second concat <$>
mapAccumLM (\(msrt0, dus0) cmm -> do
- (msrt1, dus1, cmm') <- cmmPipeline logger cmm_config msrt0 dus0 [cmm]
+ ((msrt1, cmm'), dus1) <- cmmPipeline logger cmm_config msrt0 [cmm] dus0
return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 1) cmm
unless (null cmmgroup) $
@@ -2148,12 +2149,12 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
rawCmms0 <- case cmmToRawCmmHook hooks of
Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
- Just h -> h dflags Nothing (Stream.yield cmmgroup)
+ Just h -> error "same as error below" $ h dflags Nothing (Stream.yield cmmgroup)
let dump a = do
unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
return a
- rawCmms = Stream.mapM dump rawCmms0
+ rawCmms = Stream.mapM (liftIO . dump) rawCmms0
let foreign_stubs _
| not $ null ipe_ents =
@@ -2162,7 +2163,7 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
| otherwise = NoStubs
(_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
<- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
- rawCmms
+ dus1 rawCmms
return stub_c_exists
where
no_loc = OsPathModLocation
@@ -2196,7 +2197,7 @@ doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
-> HpcInfo
- -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
+ -> IO (CgStream CmmGroupSRTs CmmCgInfos)
-- Note we produce a 'Stream' of CmmGroups, so that the
-- backend can be run incrementally. Otherwise it generates all
-- the C-- up front, which has a significant space cost.
@@ -2214,9 +2215,9 @@ doCodeGen hsc_env this_mod denv data_tycons
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
+ Just h -> error "should we change the API or implement hoist?" $ (,emptyDetUFM) <$> h (initStgToCmmConfig dflags mod) a b c d e
- let cmm_stream :: Stream IO CmmGroup (ModuleLFInfos, DetUniqFM)
+ 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
@@ -2232,45 +2233,45 @@ doCodeGen hsc_env this_mod denv data_tycons
"Cmm produced by codegen" FormatCMM (pdoc platform a)
return a
- ppr_stream1 = Stream.mapM dump1 cmm_stream
+ ppr_stream1 = Stream.mapM (liftIO . dump1) cmm_stream
cmm_config = initCmmConfig dflags
- pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos
+ pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos
pipeline_stream = do
- ((mod_srt_info, ipes, ipe_stats, dus), (lf_infos, detRnEnv)) <-
+ ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-
{-# SCC "cmmPipeline" #-}
- Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty, initDUniqSupply 'u' 1) ppr_stream1
+ 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, dus, detRnEnv)
+ cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats, detRnEnv)
return cmmCgInfos
pipeline_action
:: Logger
-> CmmConfig
- -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats, DUniqSupply)
+ -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)
-> CmmGroup
- -> IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats, DUniqSupply), CmmGroupSRTs)
- pipeline_action logger cmm_config (mod_srt_info, ipes, stats, dus) cmm_group = do
- (mod_srt_info', dus', cmm_srts) <- cmmPipeline logger cmm_config mod_srt_info dus cmm_group
+ -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)
+ pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do
+ (mod_srt_info', cmm_srts) <- withDUS $ cmmPipeline logger cmm_config mod_srt_info cmm_group
-- If -finfo-table-map is enabled, we precompute a map from info
-- tables to source locations. See Note [Mapping Info Tables to Source
-- Positions] in GHC.Stg.Debug.
(ipes', stats') <-
if (gopt Opt_InfoTableMap dflags) then
- lookupEstimatedTicks hsc_env ipes stats cmm_srts
+ liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts
else
return (ipes, stats)
- return ((mod_srt_info', ipes', stats', dus'), cmm_srts)
+ return ((mod_srt_info', ipes', stats'), cmm_srts)
dump2 a = do
unless (null a) $
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
return a
- return $ Stream.mapM dump2 pipeline_stream
+ return $ Stream.mapM (liftIO . dump2) pipeline_stream
myCoreToStg :: Logger -> DynFlags -> [Var]
-> Bool
=====================================
compiler/GHC/StgToCmm.hs
=====================================
@@ -27,6 +27,7 @@ import GHC.StgToCmm.Config
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Types (ModuleLFInfos)
+import GHC.StgToCmm.CgUtils (CgStream)
import GHC.Cmm
import GHC.Cmm.Utils
@@ -77,7 +78,7 @@ codeGen :: Logger
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
- -> Stream IO CmmGroup (ModuleLFInfos, DetUniqFM)
+ -> CgStream CmmGroup (ModuleLFInfos, DetUniqFM) -- See Note [Deterministic Uniques in the NCG] on why UniqDSMT
-- Output as a stream, so codegen can
-- be interleaved with output
@@ -90,7 +91,7 @@ codeGen logger tmpfs cfg (InfoTableProvMap denv _ _) data_tycons
; cgref <- liftIO $ initC >>= \s -> newIORef s
; uniqRnRef <- liftIO $ newIORef emptyDetUFM
; let fstate = initFCodeState $ stgToCmmPlatform cfg
- ; let cg :: FCode a -> Stream IO CmmGroup a
+ ; let cg :: FCode a -> CgStream CmmGroup a
cg fcode = do
(a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
st <- readIORef cgref
=====================================
compiler/GHC/StgToCmm/CgUtils.hs
=====================================
@@ -14,6 +14,9 @@ module GHC.StgToCmm.CgUtils (
get_Regtable_addr_from_offset,
regTableOffset,
get_GlobalReg_addr,
+
+ -- * Streaming for CG
+ CgStream
) where
import GHC.Prelude
@@ -28,6 +31,21 @@ import GHC.Cmm.CLabel
import GHC.Utils.Panic
import GHC.Cmm.Dataflow.Label
+import GHC.Data.Stream (Stream)
+import GHC.Types.Unique.DSM (UniqDSMT)
+
+-- -----------------------------------------------------------------------------
+-- Streaming
+
+-- | The Stream instantiation used for code generation.
+-- Note the underlying monad is @UniqDSMT IO@, where @UniqDSMT@ is a transformer
+-- that propagates a deterministic unique supply (essentially an incrementing
+-- counter) from which new uniques are deterministically created during the
+-- code generation stages following StgToCmm.
+-- See Note [Object determinism].
+type CgStream = Stream (UniqDSMT IO)
+
+
-- -----------------------------------------------------------------------------
-- Information about global registers
=====================================
compiler/GHC/StgToCmm/Types.hs
=====================================
@@ -22,7 +22,6 @@ import GHC.Types.Name.Set
import GHC.Utils.Outputable
-
{-
Note [Conveying CAF-info and LFInfo between modules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Unique/DSM.hs
=====================================
@@ -8,11 +8,15 @@ import Control.Monad.Fix
import GHC.Types.Unique
import qualified GHC.Utils.Monad.State.Strict as Strict
import qualified GHC.Types.Unique.Supply as USM
+import qualified Control.Monad.Trans.State.Strict as T
+import Control.Monad.IO.Class
{-
-Note [Deterministic Uniques in the NCG]
+Note [Deterministic Uniques in the CG]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explain why should the Cmm stream be UniqDSMT IO starting from StgToCmm.codeGen
+
(TODO: Is there anything about locality that I need to add? better to avoid if possible. Need to double check.)
See also Note [Object determinism] in GHC.StgToCmm
@@ -31,6 +35,9 @@ See also Note [Object determinism] in GHC.StgToCmm
-- pass.
-- todo:check: UniqSM is only used before Cmm (grep for it), afterwards only UniqDSM is used.
+
+-Describe how we thread through the uniqds in the backend that is streamed by using UniqDSMT IO in the Stream.
+That's the only sane way to thread it through all the Streaming
-}
newtype DUniqSupply = DUS Word64 -- supply uniques iteratively
@@ -90,6 +97,45 @@ class Monad m => MonadGetUnique m where
instance MonadGetUnique UniqDSM where
getUniqueM = getUniqueDSM
+-- non deterministic instance
instance MonadGetUnique USM.UniqSM where
getUniqueM = USM.getUniqueM
+--------------------------------------------------------------------------------
+-- UniqDSMT
+--------------------------------------------------------------------------------
+
+-- | Transformer version of 'UniqDSM' to use when threading a deterministic
+-- uniq supply over a Monad. Specifically, it is used in the `Stream` of Cmm
+-- decls.
+newtype UniqDSMT m result = UDSMT { unUDSMT :: T.StateT DUniqSupply m (result) }
+ deriving (Functor, Applicative, Monad, MonadIO)
+
+instance Monad m => MonadGetUnique (UniqDSMT m) where
+ getUniqueM = UDSMT $ do
+ us <- T.get
+ let (u, us') = takeUniqueFromDSupply us
+ T.put us'
+ return u
+
+-- | Like 'runUniqueDSM' but for 'UniqDSMT'
+runUDSMT :: DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply)
+runUDSMT dus (UDSMT st) = T.runStateT st dus
+
+-- | Lift an IO action that depends on, and threads through, a unique supply
+-- into UniqDSMT IO.
+withDUS :: (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a
+withDUS f = UDSMT $ do
+ us <- T.get
+ (a, us') <- liftIO (f us)
+ _ <- T.put us'
+ return a
+
+-- | Change the monad underyling an applied @UniqDSMT@, i.e. transform a
+-- @UniqDSMT m@ into a @UniqDSMT n@ given @m ~> n at .
+hoistUDSMT :: (forall x. m x -> n x) -> UniqDSMT m a -> UniqDSMT n a
+hoistUDSMT nt (UDSMT s) = UDSMT $ T.mapStateT nt s
+
+-- | Lift a monadic action @m a@ into an @UniqDSMT m a@
+liftUDSMT :: Functor m => m a -> UniqDSMT m a
+liftUDSMT m = UDSMT $ T.StateT $ \s -> (,s) <$> m
=====================================
compiler/GHC/Types/Unique/Supply.hs
=====================================
@@ -171,8 +171,7 @@ and hardcode the tag into the MonadUnique instance. On top of all the
benefits of threading the tag this *also* has the benefit of avoiding
the tag getting captured in thunks, or being passed around at runtime.
It does however come at the cost of having to use a fixed tag for all
-code run in this Monad. But remember, the tag is purely cosmetic:
-See Note [Uniques and tags].
+code run in this Monad. The tag is mostly cosmetic: See Note [Uniques and tags].
NB: It's *not* an optimization to pass around the UniqSupply inside an
IORef instead of the tag. While this would avoid frequent state updates
@@ -203,9 +202,8 @@ data UniqSupply
mkSplitUniqSupply :: Char -> IO UniqSupply
-- ^ Create a unique supply out of thin air.
--- The "tag" (Char) supplied is purely cosmetic, making it easier
--- to figure out where a Unique was born. See
--- Note [Uniques and tags].
+-- The "tag" (Char) supplied is mostly cosmetic, making it easier
+-- to figure out where a Unique was born. See Note [Uniques and tags].
--
-- The payload part of the Uniques allocated from this UniqSupply are
-- guaranteed distinct wrt all other supplies, regardless of their "tag".
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e766d8eb501a9f37802d119777117e361e09649...90b8bdb0b3bd298c31e48694546bf6ca2d2720b3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e766d8eb501a9f37802d119777117e361e09649...90b8bdb0b3bd298c31e48694546bf6ca2d2720b3
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/20240910/b58aad60/attachment-0001.html>
More information about the ghc-commits
mailing list