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

diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index a87754e..508f812 100644
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -31,27 +31,18 @@ import StgSyn
 
 import CmdLineOpts	( opt_AutoSccsOnIndividualCafs )
 import CostCentre	-- lots of things
-import Const		( Con(..) )
-import Id		( Id, mkSysLocal, idType, idName )
+import Id		( Id )
 import Module		( Module )
 import UniqSupply	( uniqFromSupply, splitUniqSupply, UniqSupply )
 import Unique           ( Unique )
-import Type		( splitForAllTys, splitTyConApp_maybe )
-import TyCon		( isFunTyCon )
 import VarSet
-import UniqSet
-import Name		( isLocallyDefinedName )
-import Util		( removeDups )
+import ListSetOps	( removeDups )
 import Outputable	
 
 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
@@ -108,24 +99,26 @@ stgMassageForProfiling mod_name us stg_binds
     ----------
     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
-    do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgCon (DataCon con) args _)))
-      | not (isSccCountCostCentre cc)
+    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 srt fv u [] (StgSCC ty cc expr))
+    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 srt fv u [] expr')
+        returnMM (StgRhsClosure cc bi fv u [] expr')
 -}
 
-    do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] body)
+    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)
@@ -139,28 +132,18 @@ stgMassageForProfiling mod_name us stg_binds
 		else 
 		     returnMM all_cafs_ccs)		`thenMM`  \ caf_ccs ->
 	   set_prevailing_cc caf_ccs (do_expr body)	`thenMM`  \ body' ->
-           returnMM (StgRhsClosure caf_ccs bi srt fv u [] body')
+           returnMM (StgRhsClosure caf_ccs bi fv u srt [] body')
 
-    do_top_rhs binder (StgRhsClosure cc bi srt fv u [] 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)
 
-{- can't do this with cost-centre stacks:  --SDM
-    do_top_rhs binder (StgRhsClosure _ bi srt fv u args (StgSCC cc expr))
-      | not (isSccCountCostCentre cc)
-	-- Top level function with trivial _scc_ in body
-	-- Attach and collect cc of trivial _scc_
-      = collectCC cc					`thenMM_`
-	set_prevailing_cc cc (do_expr expr)		`thenMM` \ expr' ->
-	returnMM (StgRhsClosure cc bi srt fv u args expr')
--}
-
-    do_top_rhs binder (StgRhsClosure no_ccs bi srt fv u args body)
+    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 srt fv u args body')
+	returnMM (StgRhsClosure subsumedCCS bi fv u srt args body')
 
       | otherwise
       = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
@@ -174,44 +157,30 @@ stgMassageForProfiling mod_name us stg_binds
     ------
     do_expr :: StgExpr -> MassageM StgExpr
 
+    do_expr (StgLit l) = returnMM (StgLit l)
+
     do_expr (StgApp fn args)
       = boxHigherOrderArgs (StgApp fn) args
 
-    do_expr (StgCon con args res_ty)
-      = boxHigherOrderArgs (\args -> StgCon con args res_ty) args
+    do_expr (StgConApp con args)
+      = boxHigherOrderArgs (\args -> StgConApp con args) args
+
+    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_`
 	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 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 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) ->
@@ -221,6 +190,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 b rhs) e
@@ -248,28 +221,23 @@ stgMassageForProfiling mod_name us stg_binds
 	-- but we don't have to worry about cafs etc.
 
 {-
-    do_rhs (StgRhsClosure closure_cc bi srt fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
+    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 srt 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 srt fv u args expr')
--}
-
-    do_rhs (StgRhsClosure cc bi srt fv u [] body)
-      = do_expr body				`thenMM` \ body' ->
-	returnMM (StgRhsClosure currentCCS bi srt fv u [] body')
-
-    do_rhs (StgRhsClosure cc bi srt fv u args body)
-      = set_lambda_cc (do_expr body)		`thenMM` \ body' ->
-	get_prevailing_cc 			`thenMM` \ prev_ccs ->
-	returnMM (StgRhsClosure currentCCS bi srt 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)
       = returnMM (StgRhsCon currentCCS con args)
@@ -301,23 +269,20 @@ boxHigherOrderArgs almost_expr args
     returnMM (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
   where
     ---------------
-    do_arg ids bindings atom@(StgConArg _) = returnMM (bindings, atom)
 
-    do_arg ids bindings atom@(StgVarArg old_var)
-      = let
-	    var_type = idType 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 (isLocallyDefinedName (idName old_var)) ||
-	     elemVarSet old_var ids ) && isFunType var_type
-	then
-	    -- make a trivial let-binding for the top-level function
-	    getUniqueMM		`thenMM` \ uniq ->
-	    let
-		new_var = mkSysLocal SLIT("sf") uniq var_type
-	    in
-	    returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
-	else
-	    returnMM (bindings, atom)
+	returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
+      where
+	var_type = idType old_var
+
+    do_arg ids bindings arg = returnMM (bindings, arg)
 
     ---------------
     mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
@@ -325,17 +290,11 @@ boxHigherOrderArgs almost_expr args
     mk_stg_let cc (new_var, old_var) body
       = let
 	    rhs_body    = StgApp old_var [{-args-}]
-	    rhs_closure = StgRhsClosure cc stgArgOcc NoSRT [{-fvs-}] ReEntrant [{-args-}] rhs_body
+	    rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
         in
 	StgLet (StgNonRec 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}
 
@@ -350,7 +309,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