X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprofiling%2FSCCfinal.lhs;h=8c3b62574d0158802c4b94cd6dd250eeb48697af;hp=101e1f889aa635fbf067b7e92a03303896c5cd50;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=040214cdd081fa7f56800a2a09f72e88f9a2d7ac diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 101e1f8..8c3b625 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -5,38 +5,29 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. -* Traverses the STG program collecting the cost centres. These are - required to declare the cost centres at the start of code - generation. + - Traverses the STG program collecting the cost centres. These are required + to declare the cost centres at the start of code generation. - Note: because of cross-module unfolding, some of these cost centres - may be from other modules. But will still have to give them - "extern" declarations. + Note: because of cross-module unfolding, some of these cost centres may be + from other modules. But will still have to give them "extern" + declarations. -* Puts on CAF cost-centres if the user has asked for individual CAF - cost-centres. + - Puts on CAF cost-centres if the user has asked for individual CAF + cost-centres. -* Ditto for individual DICT cost-centres. + - Ditto for individual DICT cost-centres. -* Boxes top-level inherited functions passed as arguments. + - Boxes top-level inherited functions passed as arguments. -* "Distributes" given cost-centres to all as-yet-unmarked RHSs. + - "Distributes" given cost-centres to all as-yet-unmarked RHSs. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module SCCfinal ( stgMassageForProfiling ) where #include "HsVersions.h" import StgSyn -import StaticFlags ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things import Id import Name @@ -48,24 +39,26 @@ import UniqSupply ( uniqFromSupply ) import VarSet import ListSetOps ( removeDups ) import Outputable +import DynFlags \end{code} \begin{code} stgMassageForProfiling - :: PackageId + :: DynFlags + -> PackageId -> Module -- module name -> UniqSupply -- unique supply -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling this_pkg mod_name us stg_binds +stgMassageForProfiling dflags this_pkg mod_name us stg_binds = let ((local_ccs, extern_ccs, cc_stacks), stg_binds2) = initMM mod_name us (do_top_bindings stg_binds) (fixed_ccs, fixed_cc_stacks) - = if opt_AutoSccsOnIndividualCafs + = if dopt Opt_AutoSccsOnIndividualCafs dflags then ([],[]) -- don't need "all CAFs" CC -- (for Prelude, we use PreludeCC) else ([all_cafs_cc], [all_cafs_ccs]) @@ -106,7 +99,7 @@ stgMassageForProfiling this_pkg mod_name us stg_binds ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args))) + do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args))) | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon @@ -129,7 +122,7 @@ stgMassageForProfiling this_pkg mod_name us stg_binds | noCCSAttached no_cc || currentOrSubsumedCCS no_cc = do -- Top level CAF without a cost centre attached -- Attach CAF cc (collect if individual CAF ccs) - caf_ccs <- if opt_AutoSccsOnIndividualCafs + caf_ccs <- if dopt Opt_AutoSccsOnIndividualCafs dflags then let cc = mkAutoCC binder modl CafCC ccs = mkSingletonCCS cc -- careful: the binder might be :Main.main, @@ -146,12 +139,12 @@ stgMassageForProfiling this_pkg mod_name us stg_binds body' <- set_prevailing_cc caf_ccs (do_expr body) return (StgRhsClosure caf_ccs bi fv u srt [] body') - do_top_rhs binder (StgRhsClosure cc bi fv u srt [] body) + do_top_rhs _ (StgRhsClosure cc _ _ _ _ [] _) -- Top level CAF with cost centre attached -- Should this be a CAF cc ??? Does this ever occur ??? = pprPanic "SCCfinal: CAF with cc:" (ppr cc) - do_top_rhs binder (StgRhsClosure no_ccs bi fv u srt args body) + do_top_rhs _ (StgRhsClosure no_ccs bi fv u srt args body) -- Top level function, probably subsumed | noCCSAttached no_ccs = do body' <- set_lambda_cc (do_expr body) @@ -160,7 +153,7 @@ stgMassageForProfiling this_pkg mod_name us stg_binds | otherwise = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs) - do_top_rhs binder (StgRhsCon ccs con args) + do_top_rhs _ (StgRhsCon _ con args) -- Top-level (static) data is not counted in heap -- profiles; nor do we set CCCS from it; so we -- just slam in dontCareCostCentre @@ -206,9 +199,7 @@ stgMassageForProfiling this_pkg mod_name us stg_binds expr' <- do_expr expr return (StgTick m n expr') -#ifdef DEBUG do_expr other = pprPanic "SCCfinal.do_expr" (ppr other) -#endif ---------------------------------- @@ -252,7 +243,7 @@ stgMassageForProfiling this_pkg mod_name us stg_binds slurpSCCs ccs e = return (e, ccs) - do_rhs (StgRhsCon cc con args) + do_rhs (StgRhsCon _ con args) = return (StgRhsCon currentCCS con args) \end{code} @@ -289,7 +280,7 @@ boxHigherOrderArgs almost_expr args = do = do -- make a trivial let-binding for the top-level function uniq <- getUniqueMM let - new_var = mkSysLocal FSLIT("sf") uniq var_type + new_var = mkSysLocal (fsLit "sf") uniq var_type return ( (new_var, old_var) : bindings, StgVarArg new_var ) where var_type = idType old_var @@ -372,8 +363,10 @@ addTopLevelIshIds [] cont = cont addTopLevelIshIds (id:ids) cont = addTopLevelIshId id (addTopLevelIshIds ids cont) +#ifdef PROF_DO_BOXING getTopLevelIshIds :: MassageM VarSet -getTopLevelIshIds = MassageM $ \mod scope_cc us ids ccs -> (ccs, ids) +getTopLevelIshIds = MassageM $ \_mod _scope_cc _us ids ccs -> (ccs, ids) +#endif \end{code} The prevailing CCS is used to tell whether we're in a top-levelish @@ -384,21 +377,19 @@ I'm sure --SDM \begin{code} set_lambda_cc :: MassageM a -> MassageM a set_lambda_cc action - = MassageM $ \mod scope_cc us ids ccs + = MassageM $ \mod _scope_cc us ids ccs -> unMassageM action mod currentCCS us ids ccs set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a set_prevailing_cc cc_to_set_to action - = MassageM $ \mod scope_cc us ids ccs + = MassageM $ \mod _scope_cc us ids ccs -> unMassageM action mod cc_to_set_to us ids ccs - -get_prevailing_cc :: MassageM CostCentreStack -get_prevailing_cc = MassageM $ \mod scope_cc us ids ccs -> (ccs, scope_cc) \end{code} \begin{code} collectCC :: CostCentre -> MassageM () -collectCC cc = MassageM $ \mod_name scope_cc us ids (local_ccs, extern_ccs, ccss) +collectCC cc + = MassageM $ \mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) -> ASSERT(not (noCCAttached cc)) if (cc `ccFromThisModule` mod_name) then ((cc : local_ccs, extern_ccs, ccss), ()) @@ -410,12 +401,14 @@ collectCC cc = MassageM $ \mod_name scope_cc us ids (local_ccs, extern_ccs, ccss -- module name (eg. the special :Main module) see bug #249, #1472, -- test prof001,prof002. collectNewCC :: CostCentre -> MassageM () -collectNewCC cc = MassageM $ \mod_name scope_cc us ids (local_ccs, extern_ccs, ccss) - -> ((cc : local_ccs, extern_ccs, ccss), ()) +collectNewCC cc + = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) + -> ((cc : local_ccs, extern_ccs, ccss), ()) collectCCS :: CostCentreStack -> MassageM () -collectCCS ccs = MassageM $ \mod_name scope_cc us ids (local_ccs, extern_ccs, ccss) - -> ASSERT(not (noCCSAttached ccs)) - ((local_ccs, extern_ccs, ccs : ccss), ()) +collectCCS ccs + = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) + -> ASSERT(not (noCCSAttached ccs)) + ((local_ccs, extern_ccs, ccs : ccss), ()) \end{code}