[project @ 2001-01-30 15:28:25 by simonmar]

[ghc-hetmet.git] / ghc / compiler / profiling / SCCfinal.lhs

diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index a87754e..4838547 100644 (file)
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -31,17 +31,12 @@ 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_`
@@ -108,10 +103,12 @@ 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 srt fv u [] (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
@@ -174,11 +171,16 @@ 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 (StgPrimApp con args res_ty)
+      = boxHigherOrderArgs (\args -> StgPrimApp con args res_ty) args
 
     do_expr (StgSCC cc expr)   -- Ha, we found a cost centre!
       = collectCC cc           `thenMM_`
@@ -190,19 +192,19 @@ stgMassageForProfiling mod_name us stg_binds
        do_alts alts            `thenMM` \ alts' ->
        returnMM (StgCase expr' fv1 fv2 bndr srt alts')
       where
-       do_alts (StgAlgAlts ty alts def) 
+       do_alts (StgAlgAlts tycon alts def) 
          = mapMM do_alt alts   `thenMM` \ alts' ->
            do_deflt def        `thenMM` \ def' ->
-           returnMM (StgAlgAlts ty alts' 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 ty alts def) 
+       do_alts (StgPrimAlts tycon alts def) 
          = mapMM do_alt alts   `thenMM` \ alts' ->
            do_deflt def        `thenMM` \ def' ->
-           returnMM (StgPrimAlts ty alts' def')
+           returnMM (StgPrimAlts tycon alts' def')
          where
            do_alt (l,e)
              = do_expr e `thenMM` \ e' ->
@@ -301,23 +303,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)
+       && isFunType var_type
+      =     -- make a trivial let-binding for the top-level function
+       getUniqueMM             `thenMM` \ uniq ->
+       let
+           new_var = mkSysLocal SLIT("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