summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/StgToCmm.hs')
-rw-r--r--compiler/GHC/StgToCmm.hs49
1 files changed, 34 insertions, 15 deletions
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
index 3d1f962267..f89f465d12 100644
--- a/compiler/GHC/StgToCmm.hs
+++ b/compiler/GHC/StgToCmm.hs
@@ -19,7 +19,7 @@ import GHC.Prelude as Prelude
import GHC.Driver.Backend
import GHC.Driver.Session
-import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
+import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.Bind
@@ -39,6 +39,7 @@ import GHC.Cmm.Graph
import GHC.Stg.Syntax
import GHC.Types.CostCentre
+import GHC.Types.IPE
import GHC.Types.HpcInfo
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -64,41 +65,56 @@ import GHC.SysTools.FileCleanup
import GHC.Data.Stream
import GHC.Data.OrdList
-import Data.IORef
import Control.Monad (when,void)
import GHC.Utils.Misc
import System.IO.Unsafe
import qualified Data.ByteString as BS
+import Data.Maybe
+import Data.IORef
+
+data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)
+ , codegen_state :: !CgState }
+
codeGen :: Logger
-> DynFlags
-> Module
+ -> InfoTableProvMap
-> [TyCon]
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [CgStgTopBinding] -- Bindings to convert
-> HpcInfo
- -> Stream IO CmmGroup ModuleLFInfos
- -- Output as a stream, so codegen can
+ -> Stream IO CmmGroup (SDoc, ModuleLFInfos) -- Output as a stream, so codegen can
-- be interleaved with output
-codeGen logger dflags this_mod data_tycons
+codeGen logger dflags this_mod ip_map@(InfoTableProvMap _) 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
- -- we would need to add a state monad layer.
- ; cgref <- liftIO $ newIORef =<< initC
- ; let cg :: FCode () -> Stream IO CmmGroup ()
+ -- we would need to add a state monad layer which regresses
+ -- allocations by 0.5-2%.
+ ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)
+ ; let cg :: FCode a -> Stream IO CmmGroup a
cg fcode = do
- cmm <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do
- st <- readIORef cgref
+ (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do
+ CodeGenState ts st <- readIORef cgref
let (a,st') = runC dflags this_mod st (getCmm fcode)
-- NB. stub-out cgs_tops and cgs_stmts. This fixes
-- a big space leak. DO NOT REMOVE!
- writeIORef cgref $! st'{ cgs_tops = nilOL,
- cgs_stmts = mkNop }
+ -- This is observed by the #3294 test
+ let !used_info
+ | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts
+ | otherwise = mempty
+ writeIORef cgref $!
+ CodeGenState used_info
+ (st'{ cgs_tops = nilOL,
+ cgs_stmts = mkNop
+ })
+
return a
yield cmm
+ return a
-- Note [codegen-split-init] the cmm_init block must come
-- FIRST. This is because when -split-objs is on we need to
@@ -107,7 +123,6 @@ codeGen logger dflags this_mod data_tycons
; cg (mkModuleInit cost_centre_info this_mod hpc_info)
; mapM_ (cg . cgTopBinding logger dflags) stg_binds
-
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
@@ -121,7 +136,11 @@ codeGen logger dflags this_mod data_tycons
; mapM_ do_tycon data_tycons
- ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)
+ ; final_state <- liftIO (readIORef cgref)
+ ; let cg_id_infos = cgs_binds . codegen_state $ final_state
+ used_info = fromOL . codegen_used_info $ final_state
+
+ ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)
-- See Note [Conveying CAF-info and LFInfo between modules] in
-- GHC.StgToCmm.Types
@@ -136,7 +155,7 @@ codeGen logger dflags this_mod data_tycons
| otherwise
= mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))
- ; return generatedInfo
+ ; return (foreign_stub, generatedInfo)
}
---------------------------------------------------------------