X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fprofiling%2FSCCfinal.lhs;h=edd3402452c0a699246c11275842a3978c7875a9;hb=61423f8842550631c7be1dfe0ebda0d179f568e8;hp=31a90eb12db0b9c5558e7db394a6ad18702d35b8;hpb=f16228e47dbaf4c5eb710bf507b3b61bc5ad7122;p=ghc-hetmet.git

diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 31a90eb..edd3402 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -43,10 +43,6 @@ infixr 9 `thenMM`, `thenMM_`
 \end{code}
 
 \begin{code}
-type CollectedCCs = ([CostCentre],	-- locally defined ones
-		     [CostCentre],	-- ones needing "extern" decls
-		     [CostCentreStack]) -- singleton stacks (for CAFs)
-
 stgMassageForProfiling
 	:: Module			-- module name
 	-> UniqSupply		    	-- unique supply
@@ -213,6 +209,10 @@ stgMassageForProfiling mod_name us stg_binds
 	= 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 srt b rhs) e
@@ -246,22 +246,17 @@ stgMassageForProfiling mod_name us stg_binds
 	returnMM (StgRhsCon cc con args)
 -}
 
-{-
-    do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
-      | not (isSccCountCostCentre cc)
-      = collectCC cc 				`thenMM_`
-	set_prevailing_cc cc (do_expr expr)	`thenMM` \ expr' ->
-	returnMM (StgRhsClosure cc bi fv u args expr')
--}
-
-    do_rhs (StgRhsClosure cc bi fv u [] body)
-      = do_expr body				`thenMM` \ body' ->
-	returnMM (StgRhsClosure currentCCS bi fv u [] body')
-
-    do_rhs (StgRhsClosure cc bi fv u args body)
-      = set_lambda_cc (do_expr body)		`thenMM` \ body' ->
-	get_prevailing_cc 			`thenMM` \ prev_ccs ->
-	returnMM (StgRhsClosure currentCCS bi fv u args body')
+    do_rhs (StgRhsClosure _ bi fv u args expr)
+      = slurpSCCs currentCCS expr		`thenMM` \ (expr', ccs) ->
+	do_expr expr'				`thenMM` \ expr'' ->
+	returnMM (StgRhsClosure ccs bi fv u 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)
       = returnMM (StgRhsCon currentCCS con args)
@@ -296,11 +291,11 @@ boxHigherOrderArgs almost_expr args
 
     do_arg ids bindings arg@(StgVarArg old_var)
 	|  (not (isLocalVar old_var) || elemVarSet old_var ids)
-	&& isFunType var_type
+	&& isFunTy (dropForAlls var_type)
       =     -- make a trivial let-binding for the top-level function
 	getUniqueMM		`thenMM` \ uniq ->
 	let
-	    new_var = mkSysLocal SLIT("sf") uniq var_type
+	    new_var = mkSysLocal FSLIT("sf") uniq var_type
 	in
 	returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
       where
@@ -319,12 +314,6 @@ boxHigherOrderArgs almost_expr args
 	StgLet (StgNonRec NoSRT{-eeek!!!-} new_var rhs_closure) body
       where
 	bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
-
-isFunType var_type 
-  = case splitForAllTys var_type of
-	(_, ty) -> case splitTyConApp_maybe ty of
-			Just (tycon,_) | isFunTyCon tycon -> True
-			_ -> False
 #endif
 \end{code}
 
@@ -339,7 +328,7 @@ type MassageM result
   =  Module		-- module name
   -> CostCentreStack	-- prevailing CostCentre
 			-- if none, subsumedCosts at top-level
-			-- useCurrentCostCentre at nested levels
+			-- currentCostCentre at nested levels
   -> UniqSupply
   -> VarSet		-- toplevel-ish Ids for boxing
   -> CollectedCCs