import StgSyn
-import CmdLineOpts ( opt_AutoSccsOnIndividualCafs )
+import Packages ( HomeModules )
+import StaticFlags ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
import Id ( Id )
import Module ( Module )
\begin{code}
stgMassageForProfiling
- :: Module -- module name
+ :: HomeModules
+ -> Module -- module name
-> UniqSupply -- unique supply
-> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
-stgMassageForProfiling mod_name us stg_binds
+stgMassageForProfiling pdeps mod_name us stg_binds
= let
((local_ccs, extern_ccs, cc_stacks),
stg_binds2)
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args)))
- | not (isSccCountCostCentre cc) && not (isDllConApp con args)
+ | not (isSccCountCostCentre cc) && not (isDllConApp pdeps con args)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
do_expr expr `thenMM` \ expr' ->
returnMM (StgSCC cc expr')
- do_expr (StgCase expr fv1 fv2 bndr srt alts)
+ do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts)
= do_expr expr `thenMM` \ expr' ->
- do_alts alts `thenMM` \ alts' ->
- returnMM (StgCase expr' fv1 fv2 bndr srt alts')
+ mapMM do_alt alts `thenMM` \ alts' ->
+ returnMM (StgCase expr' fv1 fv2 bndr srt alt_type alts')
where
- do_alts (StgAlgAlts tycon alts def)
- = mapMM do_alt alts `thenMM` \ alts' ->
- do_deflt def `thenMM` \ def' ->
- returnMM (StgAlgAlts tycon alts' def')
- where
- do_alt (id, bs, use_mask, e)
- = do_expr e `thenMM` \ e' ->
- returnMM (id, bs, use_mask, e')
-
- do_alts (StgPrimAlts tycon alts def)
- = mapMM do_alt alts `thenMM` \ alts' ->
- do_deflt def `thenMM` \ def' ->
- returnMM (StgPrimAlts tycon alts' def')
- where
- do_alt (l,e)
- = do_expr e `thenMM` \ e' ->
- returnMM (l,e')
-
- do_deflt StgNoDefault = returnMM StgNoDefault
- do_deflt (StgBindDefault e)
- = do_expr e `thenMM` \ e' ->
- returnMM (StgBindDefault e')
+ do_alt (id, bs, use_mask, e)
+ = do_expr e `thenMM` \ e' ->
+ returnMM (id, bs, use_mask, e')
do_expr (StgLet b e)
= do_let b e `thenMM` \ (b,e) ->
-}
do_rhs (StgRhsClosure _ bi fv u srt args expr)
- = slurpSCCs currentCCS expr `thenMM` \ (expr', ccs) ->
- do_expr expr' `thenMM` \ expr'' ->
+ = slurpSCCs currentCCS expr `thenMM` \ (expr', ccs) ->
+ do_expr expr' `thenMM` \ expr'' ->
returnMM (StgRhsClosure ccs bi fv u srt args expr'')
where
slurpSCCs ccs (StgSCC cc e)
= collectCC cc `thenMM_`
- slurpSCCs ccs e `thenMM` \ (e', ccs') ->
- returnMM (e', pushCCOnCCS cc ccs')
+ slurpSCCs (cc `pushCCOnCCS` ccs) e
slurpSCCs ccs e
= returnMM (e, ccs)