Commit a52ff761 authored by Simon Marlow's avatar Simon Marlow

Change the way module initialisation is done (#3252, #4417)

Previously the code generator generated small code fragments labelled
with __stginit_M for each module M, and these performed whatever
initialisation was necessary for that module and recursively invoked
the initialisation functions for imported modules.  This appraoch had
drawbacks:

 - FFI users had to call hs_add_root() to ensure the correct
   initialisation routines were called.  This is a non-standard,
   and ugly, API.

 - unless we were using -split-objs, the __stginit dependencies would
   entail linking the whole transitive closure of modules imported,
   whether they were actually used or not.  In an extreme case (#4387,
   #4417), a module from GHC might be imported for use in Template
   Haskell or an annotation, and that would force the whole of GHC to
   be needlessly linked into the final executable.

So now instead we do our initialisation with C functions marked with
__attribute__((constructor)), which are automatically invoked at
program startup time (or DSO load-time).  The C initialisers are
emitted into the stub.c file.  This means that every time we compile
with -prof or -hpc, we now get a stub file, but thanks to #3687 that
is now invisible to the user.

There are some refactorings in the RTS (particularly for HPC) to
handle the fact that initialisers now get run earlier than they did
before.

The __stginit symbols are still generated, and the hs_add_root()
function still exists (but does nothing), for backwards compatibility.
parent 5463b55b
......@@ -484,6 +484,31 @@ AC_SUBST([LdXFlag])
])# FP_PROG_LD_X
# FP_PROG_LD_BUILD_ID
# ------------
# Sets the output variable LdHasBuildId to YES if ld supports
# --build-id, or NO otherwise.
AC_DEFUN([FP_PROG_LD_BUILD_ID],
[
AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id],
[echo 'foo() {}' > conftest.c
${CC-cc} -c conftest.c
if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then
fp_cv_ld_build_id=yes
else
fp_cv_ld_build_id=no
fi
rm -rf conftest*])
if test "$fp_cv_ld_build_id" = yes; then
LdHasBuildId=YES
else
LdHasBuildId=NO
fi
AC_SUBST([LdHasBuildId])
])# FP_PROG_LD_BUILD_ID
# FP_PROG_LD_IS_GNU
# -----------------
# Sets the output variable LdIsGNULd to YES or NO, depending on whether it is
......
......@@ -51,9 +51,7 @@ module CLabel (
mkAsmTempLabel,
mkModuleInitLabel,
mkPlainModuleInitLabel,
mkModuleInitTableLabel,
mkPlainModuleInitLabel,
mkSplitMarkerLabel,
mkDirty_MUT_VAR_Label,
......@@ -70,10 +68,7 @@ module CLabel (
mkRtsPrimOpLabel,
mkRtsSlowTickyCtrLabel,
moduleRegdLabel,
moduleRegTableLabel,
mkSelectorInfoLabel,
mkSelectorInfoLabel,
mkSelectorEntryLabel,
mkCmmInfoLabel,
......@@ -102,7 +97,6 @@ module CLabel (
mkDeadStripPreventer,
mkHpcTicksLabel,
mkHpcModuleNameLabel,
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
......@@ -202,23 +196,9 @@ data CLabel
| StringLitLabel
{-# UNPACK #-} !Unique
| ModuleInitLabel
Module -- the module name
String -- its "way"
-- at some point we might want some kind of version number in
-- the module init label, to guard against compiling modules in
-- the wrong order. We can't use the interface file version however,
-- because we don't always recompile modules which depend on a module
-- whose version has changed.
| PlainModuleInitLabel -- without the version & way info
| PlainModuleInitLabel -- without the version & way info
Module
| ModuleInitTableLabel -- table of imported modules to init
Module
| ModuleRegdLabel
| CC_Label CostCentre
| CCS_Label CostCentreStack
......@@ -242,9 +222,6 @@ data CLabel
-- | Per-module table of tick locations
| HpcTicksLabel Module
-- | Per-module name of the module for Hpc
| HpcModuleNameLabel
-- | Label of an StgLargeSRT
| LargeSRTLabel
{-# UNPACK #-} !Unique
......@@ -490,7 +467,6 @@ mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
-- Constructing Code Coverage Labels
mkHpcTicksLabel = HpcTicksLabel
mkHpcModuleNameLabel = HpcModuleNameLabel
-- Constructing labels used for dynamic linking
......@@ -515,19 +491,9 @@ mkStringLitLabel = StringLitLabel
mkAsmTempLabel :: Uniquable a => a -> CLabel
mkAsmTempLabel a = AsmTempLabel (getUnique a)
mkModuleInitLabel :: Module -> String -> CLabel
mkModuleInitLabel mod way = ModuleInitLabel mod way
mkPlainModuleInitLabel :: Module -> CLabel
mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
mkModuleInitTableLabel :: Module -> CLabel
mkModuleInitTableLabel mod = ModuleInitTableLabel mod
moduleRegdLabel = ModuleRegdLabel
moduleRegTableLabel = ModuleInitTableLabel
-- -----------------------------------------------------------------------------
-- Converting between info labels and entry/ret labels.
......@@ -591,10 +557,7 @@ needsCDecl (LargeSRTLabel _) = False
needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _ _) = True
needsCDecl (CaseLabel _ _) = True
needsCDecl (ModuleInitLabel _ _) = True
needsCDecl (PlainModuleInitLabel _) = True
needsCDecl (ModuleInitTableLabel _) = True
needsCDecl ModuleRegdLabel = False
needsCDecl (PlainModuleInitLabel _) = True
needsCDecl (StringLitLabel _) = False
needsCDecl (AsmTempLabel _) = False
......@@ -612,7 +575,6 @@ needsCDecl l@(ForeignLabel{}) = not (isMathFun l)
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True
needsCDecl HpcModuleNameLabel = False
-- | Check whether a label is a local temporary for native code generation
......@@ -725,11 +687,8 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (StringLitLabel _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (ModuleInitLabel _ _) = True
externallyVisibleCLabel (PlainModuleInitLabel _)= True
externallyVisibleCLabel (ModuleInitTableLabel _)= False
externallyVisibleCLabel ModuleRegdLabel = False
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (CmmLabel _ _ _) = True
externallyVisibleCLabel (ForeignLabel{}) = True
externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
......@@ -737,8 +696,7 @@ externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel HpcModuleNameLabel = False
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
......@@ -777,9 +735,7 @@ labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel
labelType (RtsLabel (RtsApFast _)) = CodeLabel
labelType (CaseLabel _ CaseReturnInfo) = DataLabel
labelType (CaseLabel _ _) = CodeLabel
labelType (ModuleInitLabel _ _) = CodeLabel
labelType (PlainModuleInitLabel _) = CodeLabel
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
......@@ -837,10 +793,8 @@ labelDynamic this_pkg lbl =
CmmLabel pkg _ _ -> True
#endif
ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
......@@ -1008,9 +962,6 @@ pprCLbl (RtsLabel (RtsPrimOp primop))
pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
= ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr")
pprCLbl ModuleRegdLabel
= ptext (sLit "_module_registered")
pprCLbl (ForeignLabel str _ _ _)
= ftext str
......@@ -1019,22 +970,12 @@ pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
pprCLbl (CC_Label cc) = ppr cc
pprCLbl (CCS_Label ccs) = ppr ccs
pprCLbl (ModuleInitLabel mod way)
= ptext (sLit "__stginit_") <> ppr mod
<> char '_' <> text way
pprCLbl (PlainModuleInitLabel mod)
= ptext (sLit "__stginit_") <> ppr mod
pprCLbl (ModuleInitTableLabel mod)
= ptext (sLit "__stginittable_") <> ppr mod
pprCLbl (HpcTicksLabel mod)
= ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc")
pprCLbl HpcModuleNameLabel
= ptext (sLit "_hpc_module_name_str")
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <>
(case x of
......
......@@ -105,18 +105,19 @@ pprTop (CmmProc info clbl (ListGraph blocks)) =
then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info
else empty) $$
(case blocks of
[] -> empty
-- the first block doesn't get a label:
(BasicBlock _ stmts : rest) -> vcat [
(vcat [
blankLine,
extern_decls,
(if (externallyVisibleCLabel clbl)
then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
nest 8 temp_decls,
nest 8 mkFB_,
nest 8 (vcat (map pprStmt stmts)) $$
vcat (map pprBBlock rest),
case blocks of
[] -> empty
-- the first block doesn't get a label:
(BasicBlock _ stmts : rest) ->
nest 8 (vcat (map pprStmt stmts)) $$
vcat (map pprBBlock rest),
nest 8 mkFE_,
rbrace ]
)
......
......@@ -6,24 +6,14 @@
--
-----------------------------------------------------------------------------
module CgHpc (cgTickBox, initHpc, hpcTable) where
module CgHpc (cgTickBox, hpcTable) where
import OldCmm
import CLabel
import Module
import OldCmmUtils
import CgUtils
import CgMonad
import CgForeignCall
import ForeignCall
import ClosureInfo
import FastString
import HscTypes
import Panic
import BasicTypes
import Data.Char
import Data.Word
cgTickBox :: Module -> Int -> Code
cgTickBox mod n = do
......@@ -40,47 +30,10 @@ cgTickBox mod n = do
hpcTable :: Module -> HpcInfo -> Code
hpcTable this_mod (HpcInfo hpc_tickCount _) = do
emitData ReadOnlyData
[ CmmDataLabel mkHpcModuleNameLabel
, CmmString $ map (fromIntegral . ord)
(full_name_str)
++ [0]
]
emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod)
] ++
[ CmmStaticLit (CmmInt 0 W64)
| _ <- take hpc_tickCount [0::Int ..]
]
where
module_name_str = moduleNameString (Module.moduleName this_mod)
full_name_str = if modulePackageId this_mod == mainPackageId
then module_name_str
else packageIdString (modulePackageId this_mod) ++ "/" ++
module_name_str
hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"
initHpc :: Module -> HpcInfo -> Code
initHpc this_mod (HpcInfo tickCount hashNo)
= do { id <- newTemp bWord
; emitForeignCall'
PlayRisky
[CmmHinted id NoHint]
(CmmCallee
(CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction)
CCallConv
)
[ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
, CmmHinted (word32 tickCount) NoHint
, CmmHinted (word32 hashNo) NoHint
, CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint
]
(Just [])
NoC_SRT -- No SRT b/c we PlayRisky
CmmMayReturn
}
where
word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32)
mod_alloc = mkFastString "hs_hpc_module"
initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo"
......@@ -16,8 +16,7 @@ module CgProf (
costCentreFrom,
curCCS, curCCSAddr,
emitCostCentreDecl, emitCostCentreStackDecl,
emitRegisterCC, emitRegisterCCS,
emitSetCCC, emitCCS,
emitSetCCC, emitCCS,
-- Lag/drag/void stuff
ldvEnter, ldvEnterClosure, ldvRecordCreate
......@@ -347,56 +346,6 @@ sizeof_ccs_words
where
(ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
-- ---------------------------------------------------------------------------
-- Registering CCs and CCSs
-- (cc)->link = CC_LIST;
-- CC_LIST = (cc);
-- (cc)->ccID = CC_ID++;
emitRegisterCC :: CostCentre -> Code
emitRegisterCC cc = do
{ tmp <- newTemp cInt
; stmtsC [
CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
(CmmLoad cC_LIST bWord),
CmmStore cC_LIST cc_lit,
CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
]
}
where
cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-- (ccs)->prevStack = CCS_LIST;
-- CCS_LIST = (ccs);
-- (ccs)->ccsID = CCS_ID++;
emitRegisterCCS :: CostCentreStack -> Code
emitRegisterCCS ccs = do
{ tmp <- newTemp cInt
; stmtsC [
CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
(CmmLoad cCS_LIST bWord),
CmmStore cCS_LIST ccs_lit,
CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
]
}
where
ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
cC_LIST, cC_ID :: CmmExpr
cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
......
......@@ -29,7 +29,6 @@ import CgHpc
import CLabel
import OldCmm
import OldCmmUtils
import OldPprCmm
import StgSyn
......@@ -51,8 +50,7 @@ import Panic
codeGen :: DynFlags
-> Module
-> [TyCon]
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
-> IO [Cmm] -- Output
......@@ -61,8 +59,7 @@ codeGen :: DynFlags
-- possible for object splitting to split up the
-- pieces later.
codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info
= do
{ showPass dflags "CodeGen"
......@@ -73,167 +70,46 @@ codeGen dflags this_mod data_tycons imported_mods
{ cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
; cmm_tycons <- mapM cgTyCon data_tycons
; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info
this_mod imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
this_mod hpc_info)
; return (cmm_init : cmm_binds ++ concat cmm_tycons)
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
-- (say) PrelBase_True_closure, which is defined in
-- code_stuff
-- Note [codegen-split-init] the cmm_init block must
-- come FIRST. This is because when -split-objs is on
-- we need to combine this block with its
-- initialisation routines; see Note
-- [pipeline-split-init].
; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff)
; return code_stuff }
\end{code}
%************************************************************************
%* *
\subsection[codegen-init]{Module initialisation code}
%* *
%************************************************************************
/* -----------------------------------------------------------------------------
Module initialisation
The module initialisation code looks like this, roughly:
FN(__stginit_Foo) {
JMP_(__stginit_Foo_1_p)
}
FN(__stginit_Foo_1_p) {
...
}
We have one version of the init code with a module version and the
'way' attached to it. The version number helps to catch cases
where modules are not compiled in dependency order before being
linked: if a module has been compiled since any modules which depend on
it, then the latter modules will refer to a different version in their
init blocks and a link error will ensue.
The 'way' suffix helps to catch cases where modules compiled in different
ways are linked together (eg. profiled and non-profiled).
We provide a plain, unadorned, version of the module init code
which just jumps to the version with the label and way attached. The
reason for this is that when using foreign exports, the caller of
startupHaskell() must supply the name of the init function for the "top"
module in the program, and we don't want to require that this name
has the version and way info appended to it.
-------------------------------------------------------------------------- */
We initialise the module tree by keeping a work-stack,
* pointed to by Sp
* that grows downward
* Sp points to the last occupied slot
\begin{code}
mkModuleInit
mkModuleInit
:: DynFlags
-> CollectedCCs -- cost centre info
-> Module
-> [Module]
-> HpcInfo
-> HpcInfo
-> Code
mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info
= do { -- Allocate the static boolean that records if this
-- module has been registered already
emitData Data [CmmDataLabel moduleRegdLabel,
CmmStaticLit zeroCLit]
mkModuleInit dflags cost_centre_info this_mod hpc_info
= do { -- Allocate the static boolean that records if this
; whenC (opt_Hpc) $
hpcTable this_mod hpc_info
-- we emit a recursive descent module search for all modules
-- and *choose* to chase it in :Main, below.
-- In this way, Hpc enabled modules can interact seamlessly with
-- not Hpc enabled moduled, provided Main is compiled with Hpc.
; emitSimpleProc real_init_lbl $ do
{ ret_blk <- forkLabelledCode ret_code
; init_blk <- forkLabelledCode $ do
{ mod_init_code; stmtC (CmmBranch ret_blk) }
; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
ret_blk)
; stmtC (CmmBranch init_blk)
}
-- Make the "plain" procedure jump to the "real" init procedure
; emitSimpleProc plain_init_lbl jump_to_init
-- When compiling the module in which the 'main' function lives,
-- (that is, this_mod == main_mod)
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
-- Notice that the recursive descent is optional, depending on what options
-- are enabled.
; whenC (this_mod == main_mod)
(emitSimpleProc plain_main_init_lbl rec_descent_init)
}
where
-- The way string we attach to the __stginit label to catch
-- accidental linking of modules compiled in different ways. We
-- omit "dyn" from this way, because we want to be able to load
-- both dynamic and non-dynamic modules into a dynamic GHC.
way = mkBuildTag (filter want_way (ways dflags))
want_way w = not (wayRTSOnly w) && wayName w /= WayDyn
main_mod = mainModIs dflags
plain_init_lbl = mkPlainModuleInitLabel this_mod
real_init_lbl = mkModuleInitLabel this_mod way
plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) [])
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
extra_imported_mods
| this_mod == main_mod = [gHC_TOP_HANDLER]
| otherwise = []
mod_init_code = do
{ -- Set mod_reg to 1 to record that we've been here
stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)))
; whenC (opt_SccProfilingOn) $ do
initCostCentres cost_centre_info
; whenC (opt_Hpc) $
initHpc this_mod hpc_info
; mapCs (registerModuleImport way)
(imported_mods++extra_imported_mods)
}
-- The return-code pops the work stack by
-- incrementing Sp, and then jumpd to the popped item
ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1)
, CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ]
rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
then jump_to_init
else ret_code
-----------------------
registerModuleImport :: String -> Module -> Code
registerModuleImport way mod
| mod == gHC_PRIM
= nopC
| otherwise -- Push the init procedure onto the work stack
= stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1))
, CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ]
-- For backwards compatibility: user code may refer to this
-- label for calling hs_add_root().
; emitSimpleProc (mkPlainModuleInitLabel this_mod) $ return ()
; whenC (this_mod == mainModIs dflags) $
emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return ()
}
\end{code}
......@@ -252,9 +128,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
| otherwise
= do { mapM_ emitCostCentreDecl local_CCs
; mapM_ emitCostCentreStackDecl singleton_CCSs
; mapM_ emitRegisterCC local_CCs
; mapM_ emitRegisterCCS singleton_CCSs
}
}
\end{code}
%************************************************************************
......
......@@ -24,16 +24,12 @@ import StgCmmHpc
import StgCmmTicky
import MkGraph
import CmmDecl
import CmmExpr
import CmmUtils
import CLabel
import PprCmm
import StgSyn
import PrelNames
import DynFlags
import StaticFlags
import HscTypes
import CostCentre
......@@ -50,17 +46,14 @@ import Outputable
codeGen :: DynFlags
-> Module
-> [TyCon]
-> [Module] -- Directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
-> IO [Cmm] -- Output
codeGen dflags this_mod data_tycons imported_mods
codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
= do { showPass dflags "New CodeGen"
; let way = buildTag dflags
main_mod = mainModIs dflags
-- Why?
-- ; mapM_ (\x -> seq x (return ())) data_tycons
......@@ -68,10 +61,9 @@ codeGen dflags this_mod data_tycons imported_mods
; code_stuff <- initC dflags this_mod $ do
{ cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds
; cmm_tycons <- mapM cgTyCon data_tycons
; cmm_init <- getCmm (mkModuleInit way cost_centre_info
this_mod main_mod
imported_mods hpc_info)
; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init])
; cmm_init <- getCmm (mkModuleInit cost_centre_info
this_mod hpc_info)
; return (cmm_init : cmm_binds ++ concat cmm_tycons)
}
-- Put datatype_stuff after code_stuff, because the
-- datatype closure table (for enumeration types) to
......@@ -82,6 +74,12 @@ codeGen dflags this_mod data_tycons imported_mods
-- possible for object splitting to split up the
-- pieces later.
-- Note [codegen-split-init] the cmm_init block must
-- come FIRST. This is because when -split-objs is on
-- we need to combine this block with its
-- initialisation routines; see Note
-- [pipeline-split-init].
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff)
; return code_stuff }
......@@ -173,89 +171,18 @@ We initialise the module tree by keeping a work-stack,
-}
mkModuleInit
:: String -- the "way"
-> CollectedCCs -- cost centre info
:: CollectedCCs -- cost centre info
-> Module
-> Module -- name of the Main module
-> [Module]
-> HpcInfo
-> HpcInfo
-> FCode ()
mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
= do { -- Allocate the static boolean that records if this
-- module has been registered already
emitData Data [CmmDataLabel moduleRegdLabel,
CmmStaticLit zeroCLit]
; init_hpc <- initHpc this_mod hpc_info
; init_prof <- initCostCentres cost_centre_info
-- We emit a recursive descent module search for all modules
-- and *choose* to chase it in :Main, below.
-- In this way, Hpc enabled modules can interact seamlessly with
-- not Hpc enabled moduled, provided Main is compiled with Hpc.
; updfr_sz <- getUpdFrameOff
; tail <- getCode (pushUpdateFrame imports
(do updfr_sz' <- getUpdFrameOff
emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
[ check_already_done retId updfr_sz
, init_prof
, init_hpc
, tail])
-- Make the "plain" procedure jump to the "real" init procedure
; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
-- When compiling the module in which the 'main' function lives,
-- (that is, this_mod == main_mod)
-- we inject an extra stg_init procedure for stg_init_ZCMain, for the
-- RTS to invoke. We must consult the -main-is flag in case the
-- user specified a different function to Main.main
-- Notice that the recursive descent is optional, depending on what options
-- are enabled.
; whenC (this_mod == main_mod)
(emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
}
where
plain_init_lbl = mkPlainModuleInitLabel this_mod
real_init_lbl = mkModuleInitLabel this_mod way
plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
-- Main refers to GHC.TopHandler.runIO, so make sure we call the
-- init function for GHC.TopHandler.
extra_imported_mods
| this_mod == main_mod = [gHC_TOP_HANDLER]
| otherwise = []
all_imported_mods = imported_mods ++ extra_imported_mods
imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
(filter (gHC_PRIM /=) all_imported_mods)
mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
check_already_done retId updfr_sz
= mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)