X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FSCCfinal.lhs;h=508f812cb0d9d868ad5b60f47321a116121e9483;hb=aee886e70717e0f8c3ed3255229ab784a84f73f1;hp=06d4663685a8d10e24583b292573e25a9c8a72e7;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git

diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 06d4663..508f812 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -1,7 +1,7 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[SCCfinal]{Modify and collect code generation for final StgProgram}
+\section[SCCfinal]{Modify and collect code generation for final STG program}
 
 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
 
@@ -23,249 +23,224 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
 * "Distributes" given cost-centres to all as-yet-unmarked RHSs.
 
 \begin{code}
-#include "HsVersions.h"
-
 module SCCfinal ( stgMassageForProfiling ) where
 
-import Pretty		-- ToDo: rm (debugging only)
+#include "HsVersions.h"
 
-import AbsUniType	( isDictTy, getUniDataTyCon_maybe,
-			  isTupleTyCon, isFunType, getTauType,
-			  splitType -- pragmas
-			)
-import CmdLineOpts
-import CostCentre
-import Id		( mkSysLocal, getIdUniType )
-import SrcLoc		( mkUnknownSrcLoc )
 import StgSyn
-import SplitUniq
-import UniqSet		( emptyUniqSet
-			  IF_ATTACK_PRAGMAS(COMMA emptyUFM)
-			)
-import Unique
-import Util
+
+import CmdLineOpts	( opt_AutoSccsOnIndividualCafs )
+import CostCentre	-- lots of things
+import Id		( Id )
+import Module		( Module )
+import UniqSupply	( uniqFromSupply, splitUniqSupply, UniqSupply )
+import Unique           ( Unique )
+import VarSet
+import ListSetOps	( removeDups )
+import Outputable	
 
 infixr 9 `thenMM`, `thenMM_`
 \end{code}
 
 \begin{code}
-type CollectedCCs = ([CostCentre],  	    -- locally defined ones
-		     [CostCentre])	    -- ones needing "extern" decls
-
 stgMassageForProfiling
-	:: FAST_STRING -> FAST_STRING	    -- module name, group name
-	-> SplitUniqSupply		    -- unique supply
-	-> (GlobalSwitch -> Bool)	    -- command-line opts checker
-	-> [PlainStgBinding]		    -- input
-	-> (CollectedCCs, [PlainStgBinding])
+	:: Module			-- module name
+	-> UniqSupply		    	-- unique supply
+	-> [StgBinding]		    	-- input
+	-> (CollectedCCs, [StgBinding])
 
-stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
+stgMassageForProfiling mod_name us stg_binds
   = let
-	((local_ccs, extern_ccs),
+	((local_ccs, extern_ccs, cc_stacks),
 	 stg_binds2)
-	  = initMM mod_name us (mapMM do_top_binding stg_binds)
+	  = initMM mod_name us (do_top_bindings stg_binds)
 
-	fixed_ccs
-	  = if do_auto_sccs_on_cafs || doing_prelude
-	    then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
-	    else [all_cafs_cc]
+	(fixed_ccs, fixed_cc_stacks)
+	  = if opt_AutoSccsOnIndividualCafs
+	    then ([],[])  -- don't need "all CAFs" CC 
+			  -- (for Prelude, we use PreludeCC)
+	    else ([all_cafs_cc], [all_cafs_ccs])
 
 	local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
 	extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
     in
-    ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
+    ((fixed_ccs ++ local_ccs_no_dups, 
+      extern_ccs_no_dups, 
+      fixed_cc_stacks ++ cc_stacks), stg_binds2)
   where
-    do_auto_sccs_on_cafs  = sw_chkr AutoSccsOnIndividualCafs  -- only use!
---UNUSED:    do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really **
-    doing_prelude	  = sw_chkr CompilingPrelude
 
-    all_cafs_cc = if doing_prelude
-		  then preludeCafsCostCentre
-		  else mkAllCafsCC mod_name grp_name
+    all_cafs_cc  = mkAllCafsCC mod_name
+    all_cafs_ccs = mkSingletonCCS all_cafs_cc
 
     ----------
-    do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding
+    do_top_bindings :: [StgBinding] -> MassageM [StgBinding]
 
-    do_top_binding (StgNonRec b rhs) 
-      = do_top_rhs b rhs 		`thenMM` \ rhs' ->
-	returnMM (StgNonRec b rhs')
+    do_top_bindings [] = returnMM []
 
-    do_top_binding (StgRec pairs)
-      = mapMM do_pair pairs		`thenMM` \ pairs2 ->
-	returnMM (StgRec pairs2)
+    do_top_bindings (StgNonRec b rhs : bs) 
+      = do_top_rhs b rhs 		`thenMM` \ rhs' ->
+	addTopLevelIshId b (
+	   do_top_bindings bs `thenMM` \bs' ->
+	   returnMM (StgNonRec b rhs' : bs')
+	)
+
+    do_top_bindings (StgRec pairs : bs)
+      = addTopLevelIshIds binders (
+	   mapMM do_pair pairs		`thenMM` \ pairs2 ->
+	   do_top_bindings bs `thenMM` \ bs' ->
+	   returnMM (StgRec pairs2 : bs')
+	)
       where
+	binders = map fst pairs
 	do_pair (b, rhs) 
 	   = do_top_rhs b rhs	`thenMM` \ rhs2 ->
 	     returnMM (b, rhs2)
 
     ----------
-    do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs
-
-    do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs)))
-	-- top-level _scc_ around nothing but static data; toss it -- it's pointless
-      = returnMM (StgRhsCon dontCareCostCentre con args)
-
-    do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
--- OLD:
---    | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc
---	-- doubtful guard... ToDo?
-	-- Top level CAF with explicit scc expression.  Attach CAF
-	-- cost centre to StgRhsClosure and collect.
-      = let
-           calved_cc = cafifyCC cc
-	in
-	collectCC calved_cc	`thenMM_`
-	set_prevailing_cc calved_cc (
-	    do_expr expr
-	)			`thenMM`  \ expr' ->
-	returnMM (StgRhsClosure calved_cc bi fv u [] expr')
-
-    do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
-      | noCostCentreAttached cc || currentOrSubsumedCosts cc
-	-- Top level CAF without a cost centre attached: Collect
-	-- cost centre with binder name, if collecting CAFs.
-      = let
-	    (did_something, cc2)
-	      = if do_auto_sccs_on_cafs then
-		   (True, mkAutoCC binder mod_name grp_name IsCafCC)
-		else
-		   (False, all_cafs_cc)
-	in
-	(if did_something
-	 then collectCC cc2
-	 else nopMM)		`thenMM_`
-	set_prevailing_cc cc2 (
-	    do_expr body
-	)			`thenMM`  \body2 ->
-        returnMM (StgRhsClosure cc2 bi fv u [] body2)
-
-    do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
-	-- We blindly use the cc off the _scc_
-      = set_prevailing_cc cc (
-	    do_expr body
-	)		`thenMM` \ body2 ->
-	returnMM (StgRhsClosure cc bi fv u args body2)
-
-    do_top_rhs binder (StgRhsClosure cc bi fv u args body)
-      = let
-	    cc2 = if noCostCentreAttached cc
-		  then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
-		  else cc
-        in
-	set_prevailing_cc cc2 (
-	    do_expr body
-	)		`thenMM` \ body' ->
-	returnMM (StgRhsClosure cc2 bi fv u args body')
+    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)
+	-- Trivial _scc_ around nothing but static data
+	-- Eliminate _scc_ ... and turn into StgRhsCon
+
+	-- isDllConApp checks for LitLit args too
+      = returnMM (StgRhsCon dontCareCCS con args)
+
+{- Can't do this one with cost-centre stacks:  --SDM
+    do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
+      | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
+        && not (isSccCountCostCentre cc)
+	-- Top level CAF without a cost centre attached
+	-- Attach and collect cc of trivial _scc_ in body
+      = collectCC cc					`thenMM_`
+	set_prevailing_cc cc (do_expr expr)		`thenMM`  \ expr' ->
+        returnMM (StgRhsClosure cc bi fv u [] expr')
+-}
 
-    do_top_rhs binder (StgRhsCon cc con args)
-      = returnMM (StgRhsCon dontCareCostCentre con args)
+    do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body)
+      | noCCSAttached no_cc || currentOrSubsumedCCS no_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 CafCC
+			 ccs = mkSingletonCCS cc
+		     in
+		     collectCC  cc  `thenMM_`
+		     collectCCS ccs `thenMM_`
+		     returnMM ccs
+		else 
+		     returnMM all_cafs_ccs)		`thenMM`  \ caf_ccs ->
+	   set_prevailing_cc caf_ccs (do_expr body)	`thenMM`  \ body' ->
+           returnMM (StgRhsClosure caf_ccs bi fv u srt [] body')
+
+    do_top_rhs binder (StgRhsClosure cc bi fv u srt [] body)
+	-- 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)
+	-- Top level function, probably subsumed
+      | noCCSAttached no_ccs
+      = set_lambda_cc (do_expr body)	`thenMM` \ body' ->
+	returnMM (StgRhsClosure subsumedCCS bi fv u srt args body')
+
+      | otherwise
+      = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
+
+    do_top_rhs binder (StgRhsCon ccs con args)
 	-- Top-level (static) data is not counted in heap
-	-- profiles; nor do we set CCC from it; so we
+	-- profiles; nor do we set CCCS from it; so we
 	-- just slam in dontCareCostCentre
+      = returnMM (StgRhsCon dontCareCCS con args)
 
     ------
-    do_expr :: PlainStgExpr -> MassageM PlainStgExpr
+    do_expr :: StgExpr -> MassageM StgExpr
 
-    do_expr (StgApp fn args lvs)
-      = boxHigherOrderArgs (StgApp fn) args lvs
+    do_expr (StgLit l) = returnMM (StgLit l)
 
-    do_expr (StgConApp con args lvs)
-      = boxHigherOrderArgs (StgConApp con) args lvs
+    do_expr (StgApp fn args)
+      = boxHigherOrderArgs (StgApp fn) args
 
-    do_expr (StgPrimApp op args lvs)
-      = boxHigherOrderArgs (StgPrimApp op) args lvs
+    do_expr (StgConApp con args)
+      = boxHigherOrderArgs (\args -> StgConApp con args) args
 
-    do_expr (StgSCC ty cc expr)	-- Ha, we found a cost centre!
+    do_expr (StgOpApp con args res_ty)
+      = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
+
+    do_expr (StgSCC cc expr)	-- Ha, we found a cost centre!
       = collectCC cc		`thenMM_`
-	set_prevailing_cc cc (
-	    do_expr expr
-	)			`thenMM`  \ expr' ->
-	returnMM (StgSCC ty cc expr')
+	do_expr expr		`thenMM` \ expr' ->
+	returnMM (StgSCC cc expr')
 
-    do_expr (StgCase expr fv1 fv2 uniq 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 uniq alts')
+	mapMM do_alt alts 	`thenMM` \ alts' ->
+	returnMM (StgCase expr' fv1 fv2 bndr srt alt_type alts')
       where
-	do_alts (StgAlgAlts ty alts def) 
-	  = mapMM do_alt alts 	`thenMM` \ alts' ->
-	    do_deflt def	`thenMM` \ def' ->
-	    returnMM (StgAlgAlts ty alts' def')
-	  where
-	    do_alt (id, bs, use_mask, e)
-	      = do_expr e `thenMM` \ e' ->
-		returnMM (id, bs, use_mask, e')
-
-	do_alts (StgPrimAlts ty alts def) 
-	  = mapMM do_alt alts	`thenMM` \ alts' ->
-	    do_deflt def	`thenMM` \ def' ->
-	    returnMM (StgPrimAlts ty alts' def')
-	  where
-	    do_alt (l,e)
-	      = do_expr e `thenMM` \ e' ->
-		returnMM (l,e')
-
-	do_deflt StgNoDefault = returnMM StgNoDefault
-	do_deflt (StgBindDefault b is_used e) 
-	  = do_expr e			`thenMM` \ e' ->
-	    returnMM (StgBindDefault b is_used e')
+	do_alt (id, bs, use_mask, e)
+	  = do_expr e `thenMM` \ e' ->
+	    returnMM (id, bs, use_mask, e')
 
     do_expr (StgLet b e)
-      = set_prevailing_cc_maybe useCurrentCostCentre (
-	do_binding b		`thenMM` \ b' ->
-	do_expr e		`thenMM` \ e' ->
-	returnMM (StgLet b' e') )
-
-    do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
-      = set_prevailing_cc_maybe useCurrentCostCentre (
-	do_binding rhs		`thenMM` \ rhs' ->
-	do_expr body		`thenMM` \ body' ->
-	returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
-
-    ----------
-    do_binding :: PlainStgBinding -> MassageM PlainStgBinding
-
-    do_binding (StgNonRec b rhs) 
-      = do_rhs rhs 			`thenMM` \ rhs' ->
-	returnMM (StgNonRec b rhs')
-
-    do_binding (StgRec pairs)
-      = mapMM do_pair pairs `thenMM` \ new_pairs ->
-	returnMM (StgRec new_pairs)
+	= do_let b e `thenMM` \ (b,e) ->
+	  returnMM (StgLet b e)
+
+    do_expr (StgLetNoEscape lvs1 lvs2 b e)
+	= do_let b e `thenMM` \ (b,e) ->
+	  returnMM (StgLetNoEscape lvs1 lvs2 b e)
+
+#ifdef DEBUG
+    do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
+#endif
+
+    ----------------------------------
+
+    do_let (StgNonRec b rhs) e
+      = do_rhs rhs		 	`thenMM` \ rhs' ->
+	addTopLevelIshId b (
+	  do_expr e		  	`thenMM` \ e' ->
+	  returnMM (StgNonRec b rhs',e')
+        )
+
+    do_let (StgRec pairs) e
+      = addTopLevelIshIds binders (
+	   mapMM do_pair pairs	 	`thenMM` \ pairs' ->
+	   do_expr e		  	`thenMM` \ e' ->
+	   returnMM (StgRec pairs', e')
+	)
       where
-	do_pair (b, rhs)
-	  = do_rhs rhs	`thenMM` \ rhs' ->
-	    returnMM (b, rhs')
+	binders = map fst pairs
+	do_pair (b, rhs) 
+	   = do_rhs rhs			`thenMM` \ rhs2 ->
+	     returnMM (b, rhs2)
 
-    do_rhs :: PlainStgRhs -> MassageM PlainStgRhs
+    ----------------------------------
+    do_rhs :: StgRhs -> MassageM StgRhs
 	-- We play much the same game as we did in do_top_rhs above;
-	-- but we don't have to worry about cafifying, etc.
-	-- (ToDo: consolidate??)
+	-- but we don't have to worry about cafs etc.
 
-{- Patrick says NO: it will mess up our counts (WDP 95/07)
-    do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs)))
+{-
+    do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
+      | not (isSccCountCostCentre cc)
       = collectCC cc `thenMM_`
 	returnMM (StgRhsCon cc con args)
 -}
 
-    do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _))
-      = set_prevailing_cc cc (
-	    do_expr body
-	)			    `thenMM` \ body' ->
-	returnMM (StgRhsClosure cc bi fv u args body')
-
-    do_rhs (StgRhsClosure cc bi fv u args body)
-      = use_prevailing_cc_maybe cc  `thenMM` \ cc2 ->
-	set_prevailing_cc cc2 (
-	    do_expr body
-	)			    `thenMM` \ body' ->
-	returnMM (StgRhsClosure cc2 bi fv u args body')
+    do_rhs (StgRhsClosure _ bi fv u srt args 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 ccs e 
+	     = returnMM (e, ccs)
 
     do_rhs (StgRhsCon cc con args)
-      = use_prevailing_cc_maybe cc  `thenMM` \ cc2 ->
-        returnMM (StgRhsCon cc2 con args)
-      -- ToDo: Box args (if lex) Pass back let binding???
-      -- Nope: maybe later? WDP 94/06
+      = returnMM (StgRhsCon currentCCS con args)
 \end{code}
 
 %************************************************************************
@@ -274,54 +249,53 @@ stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
 %*									*
 %************************************************************************
 
+Boxing is *turned off* at the moment, until we can figure out how to
+do it properly in general.
+
 \begin{code}
 boxHigherOrderArgs
-    :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr)
-	-- An application lacking its arguments and live-var info
-    -> [PlainStgAtom]	-- arguments which we might box
-    -> PlainStgLiveVars	-- live var info, which we do *not* try
-			-- to maintain/update (setStgVarInfo will
-			-- do that)
-    -> MassageM PlainStgExpr
-
-boxHigherOrderArgs almost_expr args live_vars
-  = mapAccumMM do_arg [] args	`thenMM` \ (let_bindings, new_args) ->
-    get_prevailing_cc		`thenMM` \ cc ->
-    returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
+    :: ([StgArg] -> StgExpr)
+			-- An application lacking its arguments
+    -> [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) ->
+    returnMM (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
   where
     ---------------
-    do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
 
-    do_arg bindings atom@(StgVarAtom old_var)
-      = let
-	    var_type = getIdUniType old_var
+    do_arg ids bindings arg@(StgVarArg old_var)
+	|  (not (isLocalVar old_var) || elemVarSet old_var ids)
+	&& isFunTy (dropForAlls var_type)
+      =     -- make a trivial let-binding for the top-level function
+	getUniqueMM		`thenMM` \ uniq ->
+	let
+	    new_var = mkSysLocal FSLIT("sf") uniq var_type
 	in
-	if not (is_fun_type var_type) then
-	    returnMM (bindings, atom) -- easy
-	else
-	    -- make a trivial let-binding for the higher-order guy
-	    getUniqueMM		`thenMM` \ uniq ->
-	    let
-		new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
-	    in
-	    returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
+	returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
       where
-	is_fun_type ty = isFunType (getTauType ty)
+	var_type = idType old_var
+
+    do_arg ids bindings arg = returnMM (bindings, arg)
 
     ---------------
-    mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr
+    mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
 
     mk_stg_let cc (new_var, old_var) body
       = let
-	    rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs
-
-	    rhs = StgRhsClosure cc
-			stgArgOcc -- safe...
-			[{-junk-}] Updatable [{-no args-}] rhs_body
+	    rhs_body    = StgApp old_var [{-args-}]
+	    rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
         in
-	StgLet (StgNonRec new_var rhs) body
+	StgLet (StgNonRec new_var rhs_closure) body
       where
 	bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
+#endif
 \end{code}
 
 %************************************************************************
@@ -332,44 +306,44 @@ boxHigherOrderArgs almost_expr args live_vars
 
 \begin{code}
 type MassageM result
-  =  FAST_STRING	-- module name
-  -> CostCentre		-- prevailing CostCentre
+  =  Module		-- module name
+  -> CostCentreStack	-- prevailing CostCentre
 			-- if none, subsumedCosts at top-level
-			-- useCurrentCostCentre at nested levels
-  -> SplitUniqSupply
+			-- currentCostCentre at nested levels
+  -> UniqSupply
+  -> VarSet		-- toplevel-ish Ids for boxing
   -> CollectedCCs
   -> (CollectedCCs, result)
 
--- the initUs function also returns the final UniqueSupply and CollectedCCs
+-- the initMM function also returns the final CollectedCCs
 
-initMM :: FAST_STRING	-- module name, which we may consult
-       -> SplitUniqSupply
+initMM :: Module	-- module name, which we may consult
+       -> UniqSupply
        -> MassageM a
        -> (CollectedCCs, a)
 
-initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[])
+initMM mod_name init_us m = m mod_name noCCS init_us emptyVarSet ([],[],[])
 
 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
 
-thenMM expr cont mod scope_cc us ccs
+thenMM expr cont mod scope_cc us ids ccs
   = case splitUniqSupply us	of { (s1, s2) ->
-    case (expr mod scope_cc s1 ccs)    	of { (ccs2, result) ->
-    cont result mod scope_cc s2 ccs2 }}
+    case (expr mod scope_cc s1 ids ccs) of { (ccs2, result) ->
+    cont result mod scope_cc s2 ids ccs2 }}
 
-thenMM_ expr cont mod scope_cc us ccs
+thenMM_ expr cont mod scope_cc us ids ccs
   = case splitUniqSupply us	of { (s1, s2) ->
-    case (expr mod scope_cc s1 ccs)    	of { (ccs2, _) ->
-    cont mod scope_cc s2 ccs2 }}
+    case (expr mod scope_cc s1 ids ccs)	of { (ccs2, _) ->
+    cont mod scope_cc s2 ids ccs2 }}
 
 returnMM :: a -> MassageM a
-returnMM result mod scope_cc us ccs = (ccs, result)
+returnMM result mod scope_cc us ids ccs = (ccs, result)
 
 nopMM :: MassageM ()
-nopMM mod scope_cc us ccs = (ccs, ())
+nopMM mod scope_cc us ids ccs = (ccs, ())
 
 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
-
 mapMM f [] = returnMM []
 mapMM f (m:ms)
   = f m		`thenMM` \ r  ->
@@ -377,7 +351,6 @@ mapMM f (m:ms)
     returnMM (r:rs)
 
 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
-
 mapAccumMM f b [] = returnMM (b, [])
 mapAccumMM f b (m:ms)
   = f b m		`thenMM` \ (b2, r)  ->
@@ -385,61 +358,53 @@ mapAccumMM f b (m:ms)
     returnMM (b3, r:rs)
 
 getUniqueMM :: MassageM Unique
-getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us)
-\end{code}
+getUniqueMM mod scope_cc us ids ccs = (ccs, uniqFromSupply us)
 
-\begin{code}
-set_prevailing_cc, set_prevailing_cc_maybe
-	:: CostCentre -> MassageM a -> MassageM a
+addTopLevelIshId :: Id -> MassageM a -> MassageM a
+addTopLevelIshId id scope mod scope_cc us ids ccs
+  | isCurrentCCS scope_cc = scope mod scope_cc us ids ccs
+  | otherwise             = scope mod scope_cc us (extendVarSet ids id) ccs
 
-set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
-  = action mod cc_to_set_to us ccs
-    -- set unconditionally
+addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a
+addTopLevelIshIds [] cont = cont
+addTopLevelIshIds (id:ids) cont 
+  = addTopLevelIshId id (addTopLevelIshIds ids cont)
 
-set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs
-  = let
-	-- used when switching from top-level to nested
-	-- scope; if we were chugging along as "subsumed",
-	-- we change to the new thing; otherwise we
-	-- keep what we had.
-
-	cc_to_use
-	  = if (costsAreSubsumed scope_cc)
-	    then cc_to_set_to
-	    else scope_cc   -- carry on as before
-    in
-    action mod cc_to_use us ccs
+getTopLevelIshIds :: MassageM VarSet
+getTopLevelIshIds mod scope_cc us ids ccs = (ccs, ids)
+\end{code}
 
-get_prevailing_cc :: MassageM CostCentre
-get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
+The prevailing CCS is used to tell whether we're in a top-levelish
+position, where top-levelish is defined as "not inside a lambda".
+Prevailing CCs used to be used for something much more complicated,
+I'm sure --SDM
 
-use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre
+\begin{code}
+set_lambda_cc :: MassageM a -> MassageM a
+set_lambda_cc action mod scope_cc us ids ccs
+  = action mod currentCCS us ids ccs
 
-use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs
-  = let
-	cc_to_use
-	  = if not (noCostCentreAttached   cc_to_try
-		 || currentOrSubsumedCosts cc_to_try) then
-	        cc_to_try
-	    else
-		uncalved_scope_cc
-		-- carry on as before, but be sure it
-		-- isn't marked as CAFish (we're
-		-- crossing a lambda...)
-    in
-    (ccs, cc_to_use)
-  where
-    uncalved_scope_cc = unCafifyCC scope_cc
+set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
+set_prevailing_cc cc_to_set_to action mod scope_cc us ids ccs
+  = action mod cc_to_set_to us ids ccs
+
+get_prevailing_cc :: MassageM CostCentreStack
+get_prevailing_cc mod scope_cc us ids ccs = (ccs, scope_cc)
 \end{code}
 
 \begin{code}
 collectCC :: CostCentre -> MassageM ()
 
-collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
-  = ASSERT(not (noCostCentreAttached cc))
-    ASSERT(not (currentOrSubsumedCosts cc))
+collectCC cc 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), ())
+	((cc : local_ccs, extern_ccs, ccss), ())
     else -- must declare it "extern"
-	((local_ccs, cc : extern_ccs), ())
+	((local_ccs, cc : extern_ccs, ccss), ())
+
+collectCCS :: CostCentreStack -> MassageM ()
+
+collectCCS ccs mod_name scope_cc us ids (local_ccs, extern_ccs, ccss)
+  = ASSERT(not (noCCSAttached ccs))
+    ((local_ccs, extern_ccs, ccs : ccss), ())
 \end{code}