%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.26 1999/11/02 15:05:39 simonmar Exp $
+% $Id: AbsCSyn.lhs,v 1.27 2000/03/08 17:48:24 simonmar Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
| CClosureTbl -- table of constructors for enumerated types
TyCon -- which TyCon this table is for
+ | CModuleInitBlock -- module initialisation block
+ CAddrMode -- label for init block
+ AbstractC -- initialisation code
+
| CCostCentreDecl -- A cost centre *declaration*
Bool -- True <=> local => full declaration
-- False <=> extern; just say so
| PUSH_SEQ_FRAME -- push seq frame
| UPDATE_SU_FROM_UPD_FRAME -- pull Su out of the update frame
| SET_TAG -- set TagReg if it exists
+
+ | REGISTER_FOREIGN_EXPORT -- register a foreign exported fun
+ | REGISTER_IMPORT -- register an imported module
+
| GRAN_FETCH -- for GrAnSim only -- HWL
| GRAN_RESCHEDULE -- for GrAnSim only -- HWL
| GRAN_FETCH_AND_RESCHEDULE -- for GrAnSim only -- HWL
flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
\end{code}
\begin{code}
LvLarge _ -> SLIT("RET_VEC_BIG")
+pprAbsC stmt@(CModuleInitBlock label code) _
+ = vcat [
+ ptext SLIT("START_MOD_INIT") <> parens (ppr_amode label),
+ case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
+ pprAbsC code (costs code),
+ hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
+ ]
+
pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc
pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs
\end{code}
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
+cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
+cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH")
cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE")
cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE")
ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code
ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes
+ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code
+
+ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
\end{code}
\begin{code}
import CgConTbls ( genStaticConBits )
import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( opt_SccProfilingOn, opt_EnsureSplittableC,
- opt_D_dump_absC, opt_SccGroup
+ opt_D_dump_absC
)
import CostCentre ( CostCentre, CostCentreStack )
import FiniteMap ( FiniteMap )
import Id ( Id, idName )
-import Module ( Module, moduleString, ModuleName, moduleNameString )
+import Module ( Module, moduleString, moduleName,
+ ModuleName, moduleNameString )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import Type ( Type )
import TyCon ( TyCon, isDataTyCon )
-> ([CostCentre], -- Local cost-centres needing declaring/registering
[CostCentre], -- "extern" cost-centres needing declaring
[CostCentreStack]) -- Pre-defined "singleton" cost centre stacks
+ -> [Id] -- foreign-exported binders
-> [TyCon] -> [Class] -- Local tycons and classes
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
-codeGen mod_name imported_modules cost_centre_info
+codeGen mod_name imported_modules cost_centre_info fe_binders
tycons classes stg_binds
= mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener
let
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds)
- cost_centre_stuff = mkCostCentreStuff mod_name imported_modules cost_centre_info
+ init_stuff = mkModuleInit fe_binders mod_name imported_modules
+ cost_centre_info
- abstractC = mkAbstractCs [ cost_centre_stuff,
+ abstractC = mkAbstractCs [ init_stuff,
datatype_stuff,
code_stuff ]
cinfo = MkCompInfo mod_name
\end{code}
-Cost-centre profiling:
-Besides the usual stuff, we must produce:
+%************************************************************************
+%* *
+\subsection[codegen-init]{Module initialisation code}
+%* *
+%************************************************************************
-* Declarations for the cost-centres defined in this module;
-* Code to participate in "registering" all the cost-centres
- in the program (done at startup time when the pgm is run).
+\begin{code}
+mkModuleInit
+ :: [Id] -- foreign exported functions
+ -> Module -- module name
+ -> [ModuleName] -- import names
+ -> ([CostCentre], -- cost centre info
+ [CostCentre],
+ [CostCentreStack])
+ -> AbstractC
+mkModuleInit fe_binders mod imps cost_centre_info
+ = let
+ register_fes =
+ map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
+
+ fe_labels =
+ map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
+
+ (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
+
+ mk_reg_lbl mod_name
+ = CLitLit (_PK_ ("__init_" ++ moduleNameString mod_name)) AddrRep
-(The local cost-centres involved in this are passed
-into the code-generator, as are the imported-modules' names.)
+ mk_import_register import_name
+ = CMacroStmt REGISTER_IMPORT [mk_reg_lbl import_name]
-\begin{code}
-mkCostCentreStuff mod_name import_names (local_CCs, extern_CCs, singleton_CCSs)
- | not opt_SccProfilingOn = AbsCNop
- | otherwise = mkAbstractCs (
- map (CCostCentreDecl True) local_CCs ++
- map (CCostCentreDecl False) extern_CCs ++
- map CCostCentreStackDecl singleton_CCSs ++
- mkCcRegister local_CCs singleton_CCSs import_names
- )
+ register_imports = map mk_import_register imps
+ in
+ mkAbstractCs [
+ cc_decls,
+ CModuleInitBlock (mk_reg_lbl (Module.moduleName mod))
+ (mkAbstractCs (register_fes ++
+ cc_regs :
+ register_imports))
+ ]
+\end{code}
+
+Cost-centre profiling: Besides the usual stuff, we must produce
+declarations for the cost-centres defined in this module;
+
+(The local cost-centres involved in this are passed into the
+code-generator.)
+\begin{code}
+mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
+ | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
+ | otherwise =
+ ( mkAbstractCs (
+ map (CCostCentreDecl True) local_CCs ++
+ map (CCostCentreDecl False) extern_CCs ++
+ map CCostCentreStackDecl singleton_CCSs),
+ mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
+ )
where
- mkCcRegister ccs cc_stacks import_names
+ mkCcRegister ccs cc_stacks
= let
- register_ccs = mkAbstractCs (map mk_register ccs)
- register_imports
- = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
+ register_ccs = mkAbstractCs (map mk_register ccs)
register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)
in
- [
- CCallProfCCMacro SLIT("START_REGISTER_CCS")
- [ CLitLit (_PK_ ("_reg" ++ moduleString mod_name)) AddrRep],
- register_ccs,
- register_cc_stacks,
- register_imports,
- CCallProfCCMacro SLIT("END_REGISTER_CCS") []
- ]
+ [ register_ccs, register_cc_stacks ]
where
mk_register cc
= CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
mk_register_ccs ccs
= CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
-
- mk_import_register import_name
- = CCallProfCCMacro SLIT("REGISTER_IMPORT")
- [CLitLit (_PK_ ("_reg" ++ moduleNameString import_name)) AddrRep]
\end{code}
%************************************************************************
import VarEnv
import VarSet
import Bag ( isEmptyBag, unionBags )
-import CmdLineOpts ( opt_SccGroup, opt_SccProfilingOn )
+import CmdLineOpts ( opt_SccProfilingOn )
import CoreLint ( beginPass, endPass )
import ErrUtils ( doIfSet, pprBagOfWarnings )
import Outputable
deSugar :: Module
-> UniqSupply
-> TcResults
- -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc)
+ -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr])
deSugar mod_name us (TcResults {tc_env = global_val_env,
tc_binds = all_binds,
= do
beginPass "Desugar"
-- Do desugaring
- let (result, ds_warns) = initDs us global_val_env module_and_group
- (dsProgram mod_name all_binds rules fo_decls)
- (ds_binds, ds_rules, _, _) = result
+ let (result, ds_warns) =
+ initDs us global_val_env mod_name
+ (dsProgram mod_name all_binds rules fo_decls)
+ (ds_binds, ds_rules, _, _, _) = result
-- Display any warnings
doIfSet (not (isEmptyBag ds_warns))
doIfSet opt_D_dump_ds (printDump (ppr_ds_rules ds_rules))
return result
- where
- module_and_group = (mod_name, grp_name)
- grp_name = case opt_SccGroup of
- Just xx -> _PK_ xx
- Nothing -> _PK_ (moduleString mod_name) -- default: module name
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
mapDs dsRule rules `thenDs` \ rules' ->
let
ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds
+ fe_binders = bindersOfBinds fe_binds
in
- returnDs (ds_binds, rules', h_code, c_code)
+ returnDs (ds_binds, rules', h_code, c_code, fe_binders)
where
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
addAutoScc (TopLevelAddSccs auto_scc_fn) pair@(bndr, core_expr)
| do_auto_scc && worthSCC core_expr
- = getModuleAndGroupDs `thenDs` \ (mod,grp) ->
- returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod grp NotCafCC)) core_expr)
+ = getModuleDs `thenDs` \ mod ->
+ returnDs (bndr, Note (SCC (mkAutoCC top_bndr mod NotCafCC)) core_expr)
where do_auto_scc = isJust maybe_auto_scc
maybe_auto_scc = auto_scc_fn bndr
(Just top_bndr) = maybe_auto_scc
dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
- getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
- returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr)
+ getModuleDs `thenDs` \ mod_name ->
+ returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
-- special case to handle unboxed tuple patterns.
getFun_wrapper $
mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
in
- getModuleAndGroupDs `thenDs` \ (mod,_) ->
+ getModuleDs `thenDs` \ mod ->
getUniqueDs `thenDs` \ uniq ->
let
the_body = mkLams (tvs ++ wrapper_args) the_app
duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
- getModuleAndGroupDs,
+ getModuleDs,
getUniqueDs,
dsLookupGlobalValue,
UniqSupply
-> ValueEnv
-> SrcLoc -- to put in pattern-matching error msgs
- -> (Module, Group) -- module + group name : for SCC profiling
+ -> Module -- module: for SCC profiling
-> DsWarnings
-> (result, DsWarnings)
type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are
-- completely shadowed or incomplete patterns
-type Group = FAST_STRING
-
{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}
initDs :: UniqSupply
-> ValueEnv
- -> (Module, Group) -- module name: for profiling; (group name: from switches)
+ -> Module -- module name: for profiling
-> DsM a
-> (a, DsWarnings)
-initDs init_us genv module_and_group action
- = action init_us genv noSrcLoc module_and_group emptyBag
+initDs init_us genv mod action
+ = action init_us genv noSrcLoc mod emptyBag
thenDs :: DsM a -> (a -> DsM b) -> DsM b
andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
-thenDs m1 m2 us genv loc mod_and_grp warns
+thenDs m1 m2 us genv loc mod warns
= case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 genv loc mod_and_grp warns) of { (result, warns1) ->
- m2 result s2 genv loc mod_and_grp warns1}}
+ case (m1 s1 genv loc mod warns) of { (result, warns1) ->
+ m2 result s2 genv loc mod warns1}}
-andDs combiner m1 m2 us genv loc mod_and_grp warns
+andDs combiner m1 m2 us genv loc mod warns
= case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 genv loc mod_and_grp warns) of { (result1, warns1) ->
- case (m2 s2 genv loc mod_and_grp warns1) of { (result2, warns2) ->
+ case (m1 s1 genv loc mod warns) of { (result1, warns1) ->
+ case (m2 s2 genv loc mod warns1) of { (result2, warns2) ->
(combiner result1 result2, warns2) }}}
returnDs :: a -> DsM a
-returnDs result us genv loc mod_and_grp warns = (result, warns)
+returnDs result us genv loc mod warns = (result, warns)
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
\begin{code}
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs ty us genv loc mod_and_grp warns
+newSysLocalDs ty us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
newSysLocalsDs tys = mapDs newSysLocalDs tys
-newFailLocalDs ty us genv loc mod_and_grp warns
+newFailLocalDs ty us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
(mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
-- The UserLocal bit just helps make the code a little clearer
getUniqueDs :: DsM Unique
-getUniqueDs us genv loc mod_and_grp warns
+getUniqueDs us genv loc mod warns
= case (uniqFromSupply us) of { assigned_uniq ->
(assigned_uniq, warns) }
duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local us genv loc mod_and_grp warns
+duplicateLocalDs old_local us genv loc mod warns
= case uniqFromSupply us of { assigned_uniq ->
(setIdUnique old_local assigned_uniq, warns) }
cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us genv loc mod_and_grp warns
+cloneTyVarsDs tyvars us genv loc mod warns
= case uniqsFromSupply (length tyvars) us of { uniqs ->
(zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
\end{code}
\begin{code}
newTyVarsDs :: [TyVar] -> DsM [TyVar]
-newTyVarsDs tyvar_tmpls us genv loc mod_and_grp warns
+newTyVarsDs tyvar_tmpls us genv loc mod warns
= case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
(zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
\end{code}
\begin{code}
uniqSMtoDsM :: UniqSM a -> DsM a
-uniqSMtoDsM u_action us genv loc mod_and_grp warns
+uniqSMtoDsM u_action us genv loc mod warns
= (initUs_ us u_action, warns)
getSrcLocDs :: DsM SrcLoc
-getSrcLocDs us genv loc mod_and_grp warns
+getSrcLocDs us genv loc mod warns
= (loc, warns)
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us genv old_loc mod_and_grp warns
- = expr us genv new_loc mod_and_grp warns
+putSrcLocDs new_loc expr us genv old_loc mod warns
+ = expr us genv new_loc mod warns
dsWarn :: WarnMsg -> DsM ()
-dsWarn warn us genv loc mod_and_grp warns = ((), warns `snocBag` warn)
+dsWarn warn us genv loc mod warns = ((), warns `snocBag` warn)
\end{code}
\begin{code}
-getModuleAndGroupDs :: DsM (Module, Group)
-getModuleAndGroupDs us genv loc mod_and_grp warns
- = (mod_and_grp, warns)
+getModuleDs :: DsM Module
+getModuleDs us genv loc mod warns = (mod, warns)
\end{code}
\begin{code}
dsLookupGlobalValue :: Name -> DsM Id
-dsLookupGlobalValue name us genv loc mod_and_grp warns
+dsLookupGlobalValue name us genv loc mod warns
= case maybeWiredInIdName name of
Just id -> (id, warns)
Nothing -> (lookupWithDefaultUFM genv def name, warns)
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
opt_AutoSccsOnDicts,
- opt_SccGroup,
opt_SccProfilingOn,
opt_DoTickyProfiling,
\end{code}
A command-line {\em switch} is (generally) either on or off; e.g., the
-``verbose'' (-v) switch is either on or off. (The \tr{-G<group>}
-switch is an exception; it's set to a string, or nothing.)
+``verbose'' (-v) switch is either on or off.
A list of {\em ToDo}s is things to be done in a particular part of
processing. A (fictitious) example for the Core-to-Core simplifier
opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs")
opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs")
opt_AutoSccsOnDicts = lookUp SLIT("-fauto-sccs-on-dicts")
-opt_SccGroup = lookup_str "-G="
opt_SccProfilingOn = lookUp SLIT("-fscc-profiling")
opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
%* *
%************************************************************************
-In spite of the @Produce*@ and @SccGroup@ constructors, these things
-behave just like enumeration types.
+In spite of the @Produce*@ constructor, these things behave just like
+enumeration types.
\begin{code}
instance Eq SimplifierSwitch where
-------------------------- Desugaring ----------------
_scc_ "DeSugar"
- deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code) ->
+ deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
-------------------------- Main Core-language transformations ----------------
_scc_ "CodeGen"
codeGen this_mod imported_modules
cost_centre_info
+ fe_binders
local_tycons local_classes
stg_binds2 >>= \ abstractC ->
A Cost Centre is the argument of an _scc_ expression.
\begin{code}
-type Group = FAST_STRING -- "Group" that this CC is in; eg directory
-
data CostCentre
= NoCostCentre -- Having this constructor avoids having
-- to use "Maybe CostCentre" all the time.
| NormalCC {
- cc_name :: CcName, -- Name of the cost centre itself
- cc_mod :: ModuleName, -- Name of module defining this CC.
- cc_grp :: Group, -- "Group" that this CC is in.
- cc_is_dupd :: IsDupdCC, -- see below
- cc_is_caf :: IsCafCC -- see below
+ cc_name :: CcName, -- Name of the cost centre itself
+ cc_mod :: ModuleName, -- Name of module defining this CC.
+ cc_is_dupd :: IsDupdCC, -- see below
+ cc_is_caf :: IsCafCC -- see below
}
| AllCafsCC {
- cc_mod :: ModuleName, -- Name of module defining this CC.
- cc_grp :: Group -- "Group" that this CC is in
- -- Again, one "big" CAF cc per module, where all
- -- CAF costs are attributed unless the user asked for
- -- per-individual-CAF cost attribution.
+ cc_mod :: ModuleName -- Name of module defining this CC.
}
type CcName = EncodedFS
Building cost centres
\begin{code}
-mkUserCC :: UserFS -> Module -> Group -> CostCentre
+mkUserCC :: UserFS -> Module -> CostCentre
-mkUserCC cc_name mod group_name
- = NormalCC { cc_name = encodeFS cc_name,
- cc_mod = moduleName mod, cc_grp = group_name,
+mkUserCC cc_name mod
+ = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod,
cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
}
-mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
+mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
-mkAutoCC id mod group_name is_caf
- = NormalCC { cc_name = occNameFS (getOccName id),
- cc_mod = moduleName mod, cc_grp = group_name,
+mkAutoCC id mod is_caf
+ = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod,
cc_is_dupd = OriginalCC, cc_is_caf = is_caf
}
-mkAllCafsCC m g = AllCafsCC { cc_mod = moduleName m, cc_grp = g }
+mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m }
mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS cc = SingletonCCS cc
else text (costCentreUserName cc)
-- Printing in an interface file or in Core generally
-pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
- = text "__sccC" <+> braces (pprModuleName m <+> doubleQuotes (ptext g))
-pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
+pprCostCentreCore (AllCafsCC {cc_mod = m})
+ = text "__sccC" <+> braces (pprModuleName m)
+pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
cc_is_caf = caf, cc_is_dupd = dup})
= text "__scc" <+> braces (hsep [
ptext n,
pprModuleName m,
- doubleQuotes (ptext g),
pp_dup dup,
pp_caf caf
])
cc_ident, comma,
doubleQuotes (text (costCentreUserName cc)), comma,
doubleQuotes (text (moduleNameUserString mod_name)), comma,
- doubleQuotes (ptext grp_name), comma,
ptext is_subsumed, comma,
empty, -- Now always externally visible
text ");"]
where
cc_ident = ppCostCentreLbl cc
mod_name = cc_mod cc
- grp_name = cc_grp cc
is_subsumed = ccSubsumed cc
ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value
[CostCentreStack]) -- singleton stacks (for CAFs)
stgMassageForProfiling
- :: Module -> FAST_STRING -- module name, group name
+ :: Module -- module name
-> UniqSupply -- unique supply
-> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
-stgMassageForProfiling mod_name grp_name us stg_binds
+stgMassageForProfiling mod_name us stg_binds
= let
((local_ccs, extern_ccs, cc_stacks),
stg_binds2)
fixed_cc_stacks ++ cc_stacks), stg_binds2)
where
- all_cafs_cc = mkAllCafsCC mod_name grp_name
+ all_cafs_cc = mkAllCafsCC mod_name
all_cafs_ccs = mkSingletonCCS all_cafs_cc
----------
-- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs)
= (if opt_AutoSccsOnIndividualCafs
- then let cc = mkAutoCC binder mod_name grp_name CafCC
+ then let cc = mkAutoCC binder mod_name CafCC
ccs = mkSingletonCCS cc
in
collectCC cc `thenMM_`
%* *
%************************************************************************
+Boxing is *turned off* at the moment, until we can figure out how to
+do it properly in general.
+
\begin{code}
boxHigherOrderArgs
:: ([StgArg] -> StgExpr)
-> [StgArg] -- arguments which we might box
-> MassageM StgExpr
+#ifndef PROF_DO_BOXING
+boxHigherOrderArgs almost_expr args
+ = returnMM (almost_expr args)
+#else
boxHigherOrderArgs almost_expr args
= getTopLevelIshIds `thenMM` \ ids ->
mapAccumMM (do_arg ids) [] args `thenMM` \ (let_bindings, new_args) ->
(_, ty) -> case splitTyConApp_maybe ty of
Just (tycon,_) | isFunTyCon tycon -> True
_ -> False
-
+#endif
\end{code}
%************************************************************************
------------------------------------------------------------------------
scc :: { CostCentre }
- : '__sccC' '{' mod_name STRING '}' { AllCafsCC $3 $4 }
- | '__scc' '{' cc_name mod_name STRING cc_dup cc_caf '}'
- { NormalCC { cc_name = $3, cc_mod = $4, cc_grp = $5,
- cc_is_dupd = $6, cc_is_caf = $7 } }
+ : '__sccC' '{' mod_name '}' { AllCafsCC $3 }
+ | '__scc' '{' cc_name mod_name cc_dup cc_caf '}'
+ { NormalCC { cc_name = $3, cc_mod = $4,
+ cc_is_dupd = $5, cc_is_caf = $6 } }
cc_name :: { EncodedFS }
: CONID { $1 }
import UpdAnal ( updateAnalyse )
import SRT ( computeSRTs )
-import CmdLineOpts ( opt_SccGroup,
- opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+import CmdLineOpts ( opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
opt_DoStgLinting, opt_D_dump_stg,
StgToDo(..)
)
}
where
- grp_name = case (opt_SccGroup) of
- Just xx -> _PK_ xx
- Nothing -> _PK_ (moduleString module_name) -- default: module name
-
- -------------
stg_linter = if opt_DoStgLinting
then lintStgBindings
else ( \ whodunnit binds -> binds )
_scc_ "ProfMassage"
let
(collected_CCs, binds3)
- = stgMassageForProfiling module_name grp_name us1 binds
+ = stgMassageForProfiling module_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
unless $KNOWN_FUNNY_THING{$thing}
|| /^$TUS[@]?stg_.*$TPOSTLBL[@]?$/o # RTS internals
|| /^$TUS[@]__fexp_.*$TPOSTLBL$/o # foreign export
- || /^$TUS[@]?_reg.*$TPOSTLBL$/o # PROF: __reg<module>
+ || /^$TUS[@]?__init.*$TPOSTLBL$/o # __init<module>
|| /^$TUS[@]?.*_btm$TPOSTLBL$/o # large bitmaps
|| /^$TUS[@]?.*_closure_tbl$TPOSTLBL$/o; # closure tables
$chk[++$i] = $_;
};
&print_doctored($chk[$i], 0);
if ($TargetPlatform =~ /^powerpc-|^rs6000-/ && $printDS) {
-#ok if ($chksymb[$i] !~ /\_regMain/) {
+#ok if ($chksymb[$i] !~ /\__init_Main/) {
print OUTASM "\.csect ${chksymb[$i]}[DS]\n";
print OUTASM "${p}TOC[tc0], 0\n";
#ok }
if ( $TargetPlatform !~ /^i386-/
|| ! /^\t[a-z]/ # no instructions in here, apparently
- || /^${T_US}_reg[A-Za-z0-9_]+${T_POST_LBL}/) {
+ || /^${T_US}__init_[A-Za-z0-9_]+${T_POST_LBL}/) {
print OUTASM $_;
return;
}
%************************************************************************
\begin{code}
+use 5; # require Perl version 5 or later.
+
($Pgm = $0) =~ s|.*/||;
$ShortUsage = "\nUsage: For basic information, try the `-help' option.\n";
$LongUsage = "\n" . <<EOUSAGE;
$CollectGhcTimings = 0;
$DEBUGging = ''; # -DDEBUG and all that it entails (um... not really)
$PROFing = ''; # set to p or e if profiling
-$PROFgroup = ''; # set to group if an explicit -Ggroup specified
$PROFauto = ''; # set to relevant hsc flag if -auto or -auto-all
$PROFcaf = ''; # set to relevant hsc flag if -caf-all
$PROFdict = ''; # set to relevant hsc flag if -auto-dicts
,'-u', "${uscore}PrelException_stackOverflow_closure"
,'-u', "${uscore}PrelException_heapOverflow_closure"
,'-u', "${uscore}PrelException_NonTermination_static_closure"
+ ,'-u', "${uscore}__init_Prelude"
));
if (!$NoHaskellMain) {
unshift (@Ld_flags,'-u', "${uscore}PrelMain_mainIO_closure");
}
- if ($PROFing ne '') {
- unshift (@Ld_flags,'-u', "${uscore}_regPrelude");
- }
if ($TargetPlatform =~ /^powerpc-|^rs6000-/) {
# sometimes we have lots of toc entries...
# unshift(@Ld_flags, ('-Xlinker -bbigtoc -Xlinker -bnoquiet'));
$PROFignore_scc = '-W';
next arg; };
- /^-G(.*)$/ && do { push(@HsC_flags, "-G=$1"); # set group for cost centres
- next arg; };
-
/^-unprof-scc-auto/ && do {
# generate auto SCCs on top level bindings when not profiling.
# Used to measure optimisation effects of presence of sccs.
/* -----------------------------------------------------------------------------
- * $Id: Profiling.h,v 1.7 2000/02/29 16:58:08 simonmar Exp $
+ * $Id: Profiling.h,v 1.8 2000/03/08 17:48:26 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
char *label;
char *module;
- char *group;
/* used for accumulating costs at the end of the run... */
unsigned long time_ticks;
* charge of ordering and displaying output. */
extern hash_t max_cc_no; /* Hash on CC ptr */
extern hash_t max_mod_no; /* Hash on CC module */
-extern hash_t max_grp_no; /* Hash on CC group */
extern hash_t max_descr_no; /* Hash on closure description */
extern hash_t max_type_no; /* Hash on type description */
/* -----------------------------------------------------------------------------
- * $Id: StgMacros.h,v 1.20 2000/01/13 14:34:01 hwloidl Exp $
+ * $Id: StgMacros.h,v 1.21 2000/03/08 17:48:26 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#endif
/* -----------------------------------------------------------------------------
+ Module initialisation
+ -------------------------------------------------------------------------- */
+
+extern F_ *init_stack;
+
+#define PUSH_INIT_STACK(reg_function) \
+ *(init_stack++) = (F_)reg_function
+
+#define POP_INIT_STACK() \
+ *(--init_stack)
+
+#define START_MOD_INIT(reg_mod_name) \
+ static int _module_registered = 0; \
+ FN_(reg_mod_name) { \
+ FB_; \
+ if (! _module_registered) { \
+ _module_registered = 1; \
+ {
+ /* extern decls go here, followed by init code */
+
+#define REGISTER_FOREIGN_EXPORT(reg_fe_binder) \
+ STGCALL1(getStablePtr,reg_fe_binder)
+
+#define REGISTER_IMPORT(reg_mod_name) \
+ do { EF_(reg_mod_name); \
+ PUSH_INIT_STACK(reg_mod_name) ; \
+ } while (0)
+
+#define END_MOD_INIT() \
+ }}; \
+ JMP_(POP_INIT_STACK()); \
+ FE_ }
+
+/* -----------------------------------------------------------------------------
Support for _ccall_GC_ and _casm_GC.
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
- * $Id: StgProf.h,v 1.7 1999/09/15 13:45:14 simonmar Exp $
+ * $Id: StgProf.h,v 1.8 2000/03/08 17:48:26 simonmar Exp $
*
* (c) The GHC Team, 1998
*
-------------------------------------------------------------------------- */
-extern F_ *register_stack;
-
extern CostCentre *CC_LIST; /* registered CC list */
extern CostCentreStack *CCS_LIST; /* registered CCS list */
-# define PUSH_REGISTER_STACK(reg_function) \
- *(register_stack++) = (F_)reg_function
-
-# define POP_REGISTER_STACK() \
- *(--register_stack)
-
-# define START_REGISTER_CCS(reg_mod_name) \
- static int _module_registered = 0; \
- FN_(reg_mod_name) { \
- FB_; \
- if (! _module_registered) { \
- _module_registered = 1
-
-# define REGISTER_IMPORT(reg_mod_name) \
- do { EF_(reg_mod_name); \
- PUSH_REGISTER_STACK(reg_mod_name) ; \
- } while (0)
-
-# define END_REGISTER_CCS() \
- }; \
- JMP_(POP_REGISTER_STACK()); \
- FE_ }
-
#define REGISTER_CC(cc) \
do { \
extern CostCentre cc[]; \
* Declaring Cost Centres & Cost Centre Stacks.
* -------------------------------------------------------------------------- */
-# define CC_DECLARE(cc_ident,name,module,group,subsumed,is_local) \
- is_local CostCentre cc_ident[1] \
- = {{ 0, \
- name, \
- module, \
- group, \
- 0, \
- 0, \
- subsumed, \
+# define CC_DECLARE(cc_ident,name,module,subsumed,is_local) \
+ is_local CostCentre cc_ident[1] \
+ = {{ 0, \
+ name, \
+ module, \
+ 0, \
+ 0, \
+ subsumed, \
0 }};
# define CCS_DECLARE(ccs_ident,cc_ident,subsumed,is_local) \
/* -----------------------------------------------------------------------------
- * $Id: ProfHeap.c,v 1.5 2000/03/07 12:03:01 simonmar Exp $
+ * $Id: ProfHeap.c,v 1.6 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#ifdef DEBUG_HEAP_PROF
FILE *prof_file;
-void initProfiling( void )
+void initProfiling1( void )
+{
+}
+
+void initProfiling2( void )
{
initHeapProfiling();
}
/* -----------------------------------------------------------------------------
- * $Id: ProfRts.h,v 1.9 2000/03/07 11:53:12 simonmar Exp $
+ * $Id: ProfRts.h,v 1.10 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
* ---------------------------------------------------------------------------*/
#if defined(PROFILING) || defined(DEBUG)
-void initProfiling ( void );
-void endProfiling ( void );
+void initProfiling1 ( void );
+void initProfiling2 ( void );
+void endProfiling ( void );
extern FILE *prof_file;
#endif
/* -----------------------------------------------------------------------------
- * $Id: Profiling.c,v 1.15 2000/03/07 11:53:12 simonmar Exp $
+ * $Id: Profiling.c,v 1.16 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "ProfRts.h"
-#include "StgRun.h"
-#include "StgStartup.h"
#include "Storage.h"
#include "Proftimer.h"
#include "Itimer.h"
* constructors. It should *never* accumulate any costs.
*/
-CC_DECLARE(CC_MAIN, "MAIN", "MAIN", "MAIN", CC_IS_BORING,);
-CC_DECLARE(CC_SYSTEM, "SYSTEM", "MAIN", "MAIN", CC_IS_BORING,);
-CC_DECLARE(CC_GC, "GC", "GC", "GC", CC_IS_BORING,);
-CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "PROFILING", CC_IS_CAF,);
-CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED,);
-CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", "MAIN", CC_IS_BORING,);
+CC_DECLARE(CC_MAIN, "MAIN", "MAIN", CC_IS_BORING,);
+CC_DECLARE(CC_SYSTEM, "SYSTEM", "MAIN", CC_IS_BORING,);
+CC_DECLARE(CC_GC, "GC", "GC", CC_IS_BORING,);
+CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", CC_IS_CAF,);
+CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", CC_IS_SUBSUMED,);
+CC_DECLARE(CC_DONTZuCARE,"DONT_CARE", "MAIN", CC_IS_BORING,);
CCS_DECLARE(CCS_MAIN, CC_MAIN, CC_IS_BORING, );
CCS_DECLARE(CCS_SYSTEM, CC_SYSTEM, CC_IS_BORING, );
static CostCentreStack * ActualPush_ ( CostCentreStack *ccs, CostCentre *cc,
CostCentreStack *new_ccs );
-static void registerCostCentres ( void );
static rtsBool ccs_to_ignore ( CostCentreStack *ccs );
static void count_ticks ( CostCentreStack *ccs );
static void reportCCS ( CostCentreStack *ccs, nat indent );
-------------------------------------------------------------------------- */
void
-initProfiling (void)
+initProfiling1 (void)
{
- CostCentreStack *ccs, *next;
-
/* for the benefit of allocate()... */
CCCS = CCS_SYSTEM;
REGISTER_CCS(CCS_DONTZuCARE);
CCCS = CCS_OVERHEAD;
- registerCostCentres();
+
+ /* cost centres are registered by the per-module
+ * initialisation code now...
+ */
+}
+
+void
+initProfiling2 (void)
+{
+ CostCentreStack *ccs, *next;
+
CCCS = CCS_SYSTEM;
/* Set up the log file, and dump the header and cost centre
- * information into it.
- */
+ * information into it. */
initProfilingLogFile();
/* find all the "special" cost centre stacks, and make them children
{
CostCentre *cc;
for (cc = CC_LIST; cc != NULL; cc = cc->link) {
- fprintf(prof_file, "%d %d \"%s\" \"%s\" \"%s\"\n",
- CC_UQ, cc->ccID, cc->label, cc->module, cc->group);
+ fprintf(prof_file, "%d %d \"%s\" \"%s\"\n",
+ CC_UQ, cc->ccID, cc->label, cc->module);
}
}
}
}
/* -----------------------------------------------------------------------------
- Register Cost Centres
-
- At the moment, this process just supplies a unique integer to each
- statically declared cost centre and cost centre stack in the
- program.
-
- The code generator inserts a small function "reg<moddule>" in each
- module which registers any cost centres from that module and calls
- the registration functions in each of the modules it imports. So,
- if we call "regMain", each reachable module in the program will be
- registered.
-
- The reg* functions are compiled in the same way as STG code,
- i.e. without normal C call/return conventions. Hence we must use
- StgRun to call this stuff.
- -------------------------------------------------------------------------- */
-
-/* The registration functions use an explicit stack...
- */
-#define REGISTER_STACK_SIZE (BLOCK_SIZE * 4)
-F_ *register_stack;
-
-static void
-registerCostCentres ( void )
-{
- /* this storage will be reclaimed by the garbage collector,
- * as a large block.
- */
- register_stack = (F_ *)allocate(REGISTER_STACK_SIZE / sizeof(W_));
-
- StgRun((StgFunPtr)stg_register, &MainRegTable);
-}
-
-
-/* -----------------------------------------------------------------------------
- Set cost centre stack when entering a function. Here we implement
- the rule
-
- "if CCSfn is an initial segment of CCCS,
- then set CCCS to CCSfn,
- else append CCSfn to CCCS"
+ Set cost centre stack when entering a function.
-------------------------------------------------------------------------- */
rtsBool entering_PAP;
return CCCS;
}
- if (cccs->root == ccsfn->root) {
- return ccsfn;
- } else {
+ if (ccsfn->root->is_subsumed == CC_IS_CAF
+ || ccsfn->root->is_subsumed == CC_IS_SUBSUMED) {
return AppendCCS(cccs,ccsfn);
+ } else {
+ return ccsfn;
}
}
if (ccs != CCS_MAIN)
{
print_ccs(fp, ccs->prevStack);
- fprintf(fp, "->[%s,%s,%s]",
- ccs->cc->label, ccs->cc->module, ccs->cc->group);
+ fprintf(fp, "->[%s,%s]", ccs->cc->label, ccs->cc->module);
} else {
- fprintf(fp, "[%s,%s,%s]",
- ccs->cc->label, ccs->cc->module, ccs->cc->group);
+ fprintf(fp, "[%s,%s]", ccs->cc->label, ccs->cc->module);
}
if (ccs == CCCS) {
{
fprintf(prof_file, "%-24s %-10s", "COST CENTRE", "MODULE");
-#ifdef NOT_YET
- do_groups = have_interesting_groups(Registered_CC);
- if (do_groups) fprintf(prof_file, " %-11.11s", "GROUP");
-#endif
-
fprintf(prof_file, "%8s %5s %5s %8s %5s", "scc", "%time", "%alloc", "inner", "cafs");
if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
{
nat count;
char temp[128]; /* sigh: magic constant */
-#ifdef NOT_YET
- rtsBool do_groups = rtsFalse;
-#endif
stopProfTimer();
fprintf(prof_file, "%-*s%-*s %-10s",
indent, "", 24-indent, cc->label, cc->module);
-#ifdef NOT_YET
- if (do_groups) fprintf(prof_file, " %-11.11s",cc->group);
-#endif
-
fprintf(prof_file, "%8ld %5.1f %5.1f %8ld %5ld",
ccs->scc_count,
total_prof_ticks == 0 ? 0.0 : (ccs->time_ticks / (StgFloat) total_prof_ticks * 100),
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.c,v 1.26 2000/02/17 17:19:42 simonmar Exp $
+ * $Id: RtsFlags.c,v 1.27 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The AQUA Project, Glasgow University, 1994-1997
* (c) The GHC Team, 1998-1999
RtsFlags.ProfFlags.ccSelector = NULL;
RtsFlags.ProfFlags.modSelector = NULL;
- RtsFlags.ProfFlags.grpSelector = NULL;
RtsFlags.ProfFlags.descrSelector = NULL;
RtsFlags.ProfFlags.typeSelector = NULL;
RtsFlags.ProfFlags.kindSelector = NULL;
# if defined(PROFILING)
"",
" -h<break-down> Heap residency profile (output file <program>.hp)",
-" break-down: C = cost centre stack (default), M = module, G = group",
+" break-down: C = cost centre stack (default), M = module",
" D = closure description, Y = type description",
" T<ints>,<start> = time closure created",
" ints: no. of interval bands plotted (default 18)",
" A subset of closures may be selected by the attached cost centre using:",
" -c{mod:lab,mod:lab...}, specific module:label cost centre(s)",
" -m{mod,mod...} all cost centres from the specified modules(s)",
-" -g{grp,grp...} all cost centres from the specified group(s)",
" Selections can also be made by description, type, kind and age:",
" -d{des,des...} closures with specified closure descriptions",
" -y{typ,typ...} closures with specified type descriptions",
case MODchar:
RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_MOD;
break;
- case GRPchar:
- RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_GRP;
- break;
case DESCRchar:
RtsFlags.ProfFlags.doHeapProfile = HEAP_BY_DESCR;
break;
error = rtsTrue;
}
break;
- case GRPchar:
- max_grp_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_grp_no == 0) {
- prog_belch("bad number of groups %s", rts_argv[arg]);
- error = rtsTrue;
- }
- break;
case DESCRchar:
max_descr_no = (hash_t) decode(rts_argv[arg]+3);
if (max_descr_no == 0) {
) break;
case 'c': /* cost centre label select */
- case 'g': /* cost centre group select */
case 'd': /* closure descr select */
case 'y': /* closure type select */
PROFILING_BUILD_ONLY(
case 'm': /* cost centre module select */
RtsFlags.ProfFlags.modSelector = left + 1;
break;
- case 'g': /* cost centre group select */
- RtsFlags.ProfFlags.grpSelector = left + 1;
- break;
case 'd': /* closure descr select */
RtsFlags.ProfFlags.descrSelector = left + 1;
break;
/* -----------------------------------------------------------------------------
- * $Id: RtsFlags.h,v 1.21 2000/02/17 17:19:42 simonmar Exp $
+ * $Id: RtsFlags.h,v 1.22 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
# define HEAP_BY_CCS 1
# define HEAP_BY_MOD 2
-# define HEAP_BY_GRP 3
# define HEAP_BY_DESCR 4
# define HEAP_BY_TYPE 5
# define HEAP_BY_TIME 6
# define CCchar 'C'
# define MODchar 'M'
-# define GRPchar 'G'
# define DESCRchar 'D'
# define TYPEchar 'Y'
# define TIMEchar 'T'
char *ccSelector;
char *modSelector;
- char *grpSelector;
char *descrSelector;
char *typeSelector;
char *kindSelector;
/* -----------------------------------------------------------------------------
- * $Id: RtsStartup.c,v 1.30 2000/02/22 12:09:24 simonmar Exp $
+ * $Id: RtsStartup.c,v 1.31 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
#include "Itimer.h"
#include "Weak.h"
#include "Ticky.h"
+#include "StgRun.h"
+#include "StgStartup.h"
#if defined(PROFILING) || defined(DEBUG)
# include "ProfRts.h"
static ullong startTime = 0;
#endif
+static void initModules ( void );
+
void
startupHaskell(int argc, char *argv[])
{
initStablePtrTable();
#if defined(PROFILING) || defined(DEBUG)
- initProfiling();
+ initProfiling1();
+#endif
+
+ /* run the per-module initialisation code */
+ initModules();
+
+#if defined(PROFILING) || defined(DEBUG)
+ initProfiling2();
#endif
/* start the ticker */
end_init();
}
-/*
+/* -----------------------------------------------------------------------------
+ Per-module initialisation
+
+ This process traverses all the compiled modules in the program
+ starting with "Main", and performing per-module initialisation for
+ each one.
+
+ So far, two things happen at initialisation time:
+
+ - we register stable names for each foreign-exported function
+ in that module. This prevents foreign-exported entities, and
+ things they depend on, from being garbage collected.
+
+ - we supply a unique integer to each statically declared cost
+ centre and cost centre stack in the program.
+
+ The code generator inserts a small function "__init_<moddule>" in each
+ module and calls the registration functions in each of the modules
+ it imports. So, if we call "__init_Main", each reachable module in the
+ program will be registered.
+
+ The init* functions are compiled in the same way as STG code,
+ i.e. without normal C call/return conventions. Hence we must use
+ StgRun to call this stuff.
+ -------------------------------------------------------------------------- */
+
+/* The init functions use an explicit stack...
+ */
+#define INIT_STACK_SIZE (BLOCK_SIZE * 4)
+F_ *init_stack;
+
+static void
+initModules ( void )
+{
+ /* this storage will be reclaimed by the garbage collector,
+ * as a large block.
+ */
+ init_stack = (F_ *)allocate(INIT_STACK_SIZE / sizeof(W_));
+
+ StgRun((StgFunPtr)stg_init, NULL/* no reg table */);
+}
+
+/* -----------------------------------------------------------------------------
* Shutting down the RTS - two ways of doing this, one which
* calls exit(), one that doesn't.
*
* (shutdownHaskellAndExit() is called by System.exitWith).
+ * -----------------------------------------------------------------------------
*/
void
shutdownHaskellAndExit(int n)
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.h,v 1.3 1999/02/05 16:03:00 simonm Exp $
+ * $Id: StgStartup.h,v 1.4 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
EXTFUN(stg_returnToStackTop);
EXTFUN(stg_enterStackTop);
-#ifdef PROFILING
-EXTFUN(stg_register_ret);
-EXTFUN(stg_register);
-EXTFUN(regPrelGHC);
-#endif
+EXTFUN(stg_init_ret);
+EXTFUN(stg_init);
+EXTFUN(__init_PrelGHC);
/* -----------------------------------------------------------------------------
- * $Id: StgStartup.hc,v 1.5 1999/05/13 17:31:13 simonm Exp $
+ * $Id: StgStartup.hc,v 1.6 2000/03/08 17:48:24 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
Special STG entry points for module registration.
-------------------------------------------------------------------------- */
-#ifdef PROFILING
-
-STGFUN(stg_register_ret)
+STGFUN(stg_init_ret)
{
FB_
JMP_(StgReturn);
FE_
}
-STGFUN(stg_register)
+STGFUN(stg_init)
{
- EF_(_regMain);
- EF_(_regPrelude);
+ EF_(__init_Main);
+ EF_(__init_Prelude);
FB_
- PUSH_REGISTER_STACK(stg_register_ret);
- PUSH_REGISTER_STACK(_regPrelude);
- JMP_(_regMain);
+ PUSH_INIT_STACK(stg_init_ret);
+ PUSH_INIT_STACK(__init_Prelude);
+ JMP_(__init_Main);
FE_
}
/* PrelGHC doesn't really exist... */
-START_REGISTER_CCS(_regPrelGHC);
-END_REGISTER_CCS();
-
-#endif
+START_MOD_INIT(__init_PrelGHC);
+END_MOD_INIT();
projects / ghc-hetmet.git / commitdiff