From: simonmar Date: Wed, 8 Mar 2000 17:48:26 +0000 (+0000) Subject: [project @ 2000-03-08 17:48:24 by simonmar] X-Git-Tag: Approximately_9120_patches~5043 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=de896403dfe48bc999e5501eb8b517624dd2e5d4;p=ghc-hetmet.git [project @ 2000-03-08 17:48:24 by simonmar] - generalise the per-module initialisation stubs so that we use it in normal (non-profiled) code too. The initialisation stubs are now called '__init_' rather than '_reg'. - Register foreign exported functions as stable pointers in the initialisation code for the module. This fixes the foreign export problems reported by several people. - remove the concept of "module groups" from the profiling subsystem. - change the profiling semantics slightly; it should be unnecessary to use '-caf-all' to get reasonable profiles now. --- diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 6caa9c5..8b3bfd4 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (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} @@ -201,6 +201,10 @@ stored in a mixed type location.) | 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 @@ -235,6 +239,10 @@ data CStmtMacro | 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 diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index ac795f7..18ef770 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -376,6 +376,7 @@ flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt) 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} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index da827f5..008cada 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -563,6 +563,14 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ 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} @@ -1157,6 +1165,8 @@ cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME") 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") @@ -1511,6 +1521,9 @@ ppr_decls_AbsC (CSRT lbl closure_lbls) 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} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 95926aa..2e374b4 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -32,12 +32,13 @@ import CgCon ( cgTopRhsCon ) 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 ) @@ -57,19 +58,21 @@ codeGen :: Module -- Module name -> ([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 ] @@ -89,52 +92,77 @@ codeGen mod_name imported_modules cost_centre_info 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} %************************************************************************ diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index cd2da89..2aa24b7 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -29,7 +29,7 @@ import Name ( isLocallyDefined ) 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 @@ -49,7 +49,7 @@ start. 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, @@ -58,9 +58,10 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, = 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)) @@ -72,11 +73,6 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, 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 -> @@ -84,8 +80,9 @@ dsProgram mod_name all_binds rules fo_decls 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 diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 2131f60..c43f985 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -205,8 +205,8 @@ addAutoScc :: AutoScc -- if needs be, decorate toplevs? 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 diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 036fea8..bce1b1d 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -296,8 +296,8 @@ dsExpr (CCall lbl args may_gc is_asm result_ty) 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. diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index b5a1154..4f4e285 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -287,7 +287,7 @@ dsFExport i ty mod_name ext_name cconv isDyn = 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 1c6c033..edd9a2c 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -13,7 +13,7 @@ module DsMonad ( duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newFailLocalDs, getSrcLocDs, putSrcLocDs, - getModuleAndGroupDs, + getModuleDs, getUniqueDs, dsLookupGlobalValue, @@ -55,15 +55,13 @@ type DsM result = 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 #-} @@ -72,29 +70,29 @@ type Group = FAST_STRING 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 [] @@ -141,29 +139,29 @@ it easier to read debugging output. \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} @@ -171,7 +169,7 @@ cloneTyVarsDs tyvars us genv loc mod_and_grp warns \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} @@ -181,31 +179,30 @@ the @SrcLoc@ being carried around. \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) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 44b652c..ed37ca6 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -75,7 +75,6 @@ module CmdLineOpts ( opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnIndividualCafs, opt_AutoSccsOnDicts, - opt_SccGroup, opt_SccProfilingOn, opt_DoTickyProfiling, @@ -172,8 +171,7 @@ import PrelArr ( Array(..) ) \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} -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 @@ -366,7 +364,6 @@ opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs") 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") @@ -555,8 +552,8 @@ matchSwInt opt str sw = case startsWith str opt of %* * %************************************************************************ -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 diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index c0b2066..5eea51b 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -152,7 +152,7 @@ doIt (core_cmds, stg_cmds) -------------------------- 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 ---------------- @@ -200,6 +200,7 @@ doIt (core_cmds, stg_cmds) _scc_ "CodeGen" codeGen this_mod imported_modules cost_centre_info + fe_binders local_tycons local_classes stg_binds2 >>= \ abstractC -> diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 5d0ef91..9770ecb 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -98,26 +98,19 @@ data CostCentreStack 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 @@ -185,23 +178,21 @@ currentOrSubsumedCCS _ = False 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 @@ -343,14 +334,13 @@ instance Outputable CostCentre where 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 ]) @@ -391,7 +381,6 @@ pprCostCentreDecl is_local cc 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 ");"] @@ -400,7 +389,6 @@ pprCostCentreDecl is_local cc 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 diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 6afed02..a87754e 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -53,12 +53,12 @@ type CollectedCCs = ([CostCentre], -- locally defined ones [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) @@ -78,7 +78,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds 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 ---------- @@ -130,7 +130,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds -- 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_` @@ -281,6 +281,9 @@ stgMassageForProfiling mod_name grp_name us stg_binds %* * %************************************************************************ +Boxing is *turned off* at the moment, until we can figure out how to +do it properly in general. + \begin{code} boxHigherOrderArgs :: ([StgArg] -> StgExpr) @@ -288,6 +291,10 @@ boxHigherOrderArgs -> [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) -> @@ -329,7 +336,7 @@ isFunType var_type (_, ty) -> case splitTyConApp_maybe ty of Just (tycon,_) | isFunTyCon tycon -> True _ -> False - +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 30fff39..82e2286 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -823,10 +823,10 @@ ccall_string :: { FAST_STRING } ------------------------------------------------------------------------ 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 } diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 64a3652..268621b 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -19,8 +19,7 @@ import StgVarInfo ( setStgVarInfo ) 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(..) ) @@ -81,11 +80,6 @@ stg2stg stg_todos module_name us binds } 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 ) @@ -121,7 +115,7 @@ stg2stg stg_todos module_name us 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 diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl index 6139b3c..c416a8b 100644 --- a/ghc/driver/ghc-asm.lprl +++ b/ghc/driver/ghc-asm.lprl @@ -564,7 +564,7 @@ sub mangle_asm { unless $KNOWN_FUNNY_THING{$thing} || /^$TUS[@]?stg_.*$TPOSTLBL[@]?$/o # RTS internals || /^$TUS[@]__fexp_.*$TPOSTLBL$/o # foreign export - || /^$TUS[@]?_reg.*$TPOSTLBL$/o # PROF: __reg + || /^$TUS[@]?__init.*$TPOSTLBL$/o # __init || /^$TUS[@]?.*_btm$TPOSTLBL$/o # large bitmaps || /^$TUS[@]?.*_closure_tbl$TPOSTLBL$/o; # closure tables $chk[++$i] = $_; @@ -887,7 +887,7 @@ sub mangle_asm { }; &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 } @@ -1168,7 +1168,7 @@ sub print_doctored { 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; } diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 8d04c30..e3eb56b 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -12,6 +12,8 @@ It is written in \tr{perl}. The first section includes a long %************************************************************************ \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" . <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); } } } @@ -262,47 +266,7 @@ endProfiling ( void ) } /* ----------------------------------------------------------------------------- - 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" 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; @@ -315,10 +279,11 @@ EnterFunCCS ( CostCentreStack *cccs, CostCentreStack *ccsfn ) 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; } } @@ -515,11 +480,9 @@ print_ccs (FILE *fp, CostCentreStack *ccs) 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) { @@ -647,11 +610,6 @@ fprint_header( void ) { 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) { @@ -670,9 +628,6 @@ report_ccs_profiling( void ) { nat count; char temp[128]; /* sigh: magic constant */ -#ifdef NOT_YET - rtsBool do_groups = rtsFalse; -#endif stopProfTimer(); @@ -742,10 +697,6 @@ reportCCS(CostCentreStack *ccs, nat indent) 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), diff --git a/ghc/rts/RtsFlags.c b/ghc/rts/RtsFlags.c index 19d58cc..5f043f2 100644 --- a/ghc/rts/RtsFlags.c +++ b/ghc/rts/RtsFlags.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 @@ -208,7 +208,6 @@ void initRtsFlagsDefaults(void) RtsFlags.ProfFlags.ccSelector = NULL; RtsFlags.ProfFlags.modSelector = NULL; - RtsFlags.ProfFlags.grpSelector = NULL; RtsFlags.ProfFlags.descrSelector = NULL; RtsFlags.ProfFlags.typeSelector = NULL; RtsFlags.ProfFlags.kindSelector = NULL; @@ -355,7 +354,7 @@ usage_text[] = { # if defined(PROFILING) "", " -h Heap residency profile (output file .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, = time closure created", " ints: no. of interval bands plotted (default 18)", @@ -363,7 +362,6 @@ usage_text[] = { " 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", @@ -741,9 +739,6 @@ error = rtsTrue; 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; @@ -791,13 +786,6 @@ error = rtsTrue; 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) { @@ -822,7 +810,6 @@ error = rtsTrue; ) 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( @@ -844,9 +831,6 @@ error = rtsTrue; 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; diff --git a/ghc/rts/RtsFlags.h b/ghc/rts/RtsFlags.h index 6931fe8..7f9a360 100644 --- a/ghc/rts/RtsFlags.h +++ b/ghc/rts/RtsFlags.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -87,7 +87,6 @@ struct PROFILING_FLAGS { # 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 @@ -96,14 +95,12 @@ struct PROFILING_FLAGS { # 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; diff --git a/ghc/rts/RtsStartup.c b/ghc/rts/RtsStartup.c index 7208ae0..6de0350 100644 --- a/ghc/rts/RtsStartup.c +++ b/ghc/rts/RtsStartup.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -19,6 +19,8 @@ #include "Itimer.h" #include "Weak.h" #include "Ticky.h" +#include "StgRun.h" +#include "StgStartup.h" #if defined(PROFILING) || defined(DEBUG) # include "ProfRts.h" @@ -46,6 +48,8 @@ static int rts_has_started_up = 0; static ullong startTime = 0; #endif +static void initModules ( void ); + void startupHaskell(int argc, char *argv[]) { @@ -125,7 +129,14 @@ 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 */ @@ -166,11 +177,54 @@ startupHaskell(int argc, char *argv[]) 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_" 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) diff --git a/ghc/rts/StgStartup.h b/ghc/rts/StgStartup.h index 0bd3b52..5d0827d 100644 --- a/ghc/rts/StgStartup.h +++ b/ghc/rts/StgStartup.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -12,8 +12,6 @@ EXTFUN(stg_stop_thread_entry); 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); diff --git a/ghc/rts/StgStartup.hc b/ghc/rts/StgStartup.hc index b3591d1..631e991 100644 --- a/ghc/rts/StgStartup.hc +++ b/ghc/rts/StgStartup.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -131,29 +131,25 @@ STGFUN(stg_enterStackTop) 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();