Commit de896403 authored by simonmar's avatar simonmar

[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_<module>' rather than '_reg<module>'.

- 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.
parent 54e6a4e1
%
% (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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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)
......
......@@ -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<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
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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
%* *