[project @ 2000-03-23 17:45:17 by simonpj]

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

diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs
index 6afed02..5af0543 100644 (file)
--- a/ghc/compiler/profiling/SCCfinal.lhs
+++ b/ghc/compiler/profiling/SCCfinal.lhs
@@ -31,7 +31,6 @@ import StgSyn
 
 import CmdLineOpts     ( opt_AutoSccsOnIndividualCafs )
 import CostCentre      -- lots of things
-import Const           ( Con(..) )
 import Id              ( Id, mkSysLocal, idType, idName )
 import Module          ( Module )
 import UniqSupply      ( uniqFromSupply, splitUniqSupply, UniqSupply )
@@ -40,7 +39,7 @@ import Type           ( splitForAllTys, splitTyConApp_maybe )
 import TyCon           ( isFunTyCon )
 import VarSet
 import UniqSet
-import Name            ( isLocallyDefinedName )
+import Name            ( isLocallyDefined )
 import Util            ( removeDups )
 import Outputable      
 
@@ -53,12 +52,12 @@ type CollectedCCs = ([CostCentre],  -- locally defined ones
                     [CostCentreStack]) -- singleton stacks (for CAFs)
 
 stgMassageForProfiling
-       :: Module -> FAST_STRING        -- module name, group name
+       :: Module                       -- module name
        -> UniqSupply                   -- unique supply
        -> [StgBinding]                 -- input
        -> (CollectedCCs, [StgBinding])
 
-stgMassageForProfiling mod_name grp_name us stg_binds
+stgMassageForProfiling mod_name us stg_binds
   = let
        ((local_ccs, extern_ccs, cc_stacks),
         stg_binds2)
@@ -78,7 +77,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds
       fixed_cc_stacks ++ cc_stacks), stg_binds2)
   where
 
-    all_cafs_cc  = mkAllCafsCC mod_name grp_name
+    all_cafs_cc  = mkAllCafsCC mod_name
     all_cafs_ccs = mkSingletonCCS all_cafs_cc
 
     ----------
@@ -108,7 +107,7 @@ stgMassageForProfiling mod_name grp_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 _)))
+    do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgConApp con args)))
       | not (isSccCountCostCentre cc)
        -- Trivial _scc_ around nothing but static data
        -- Eliminate _scc_ ... and turn into StgRhsCon
@@ -130,7 +129,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds
        -- 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 grp_name CafCC
+               then let cc = mkAutoCC binder mod_name CafCC
                         ccs = mkSingletonCCS cc
                     in
                     collectCC  cc  `thenMM_`
@@ -174,11 +173,16 @@ stgMassageForProfiling mod_name grp_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_`
@@ -281,6 +285,9 @@ stgMassageForProfiling mod_name grp_name us stg_binds
 %*                                                                     *
 %************************************************************************
 
+Boxing is *turned off* at the moment, until we can figure out how to
+do it properly in general.
+
 \begin{code}
 boxHigherOrderArgs
     :: ([StgArg] -> StgExpr)
@@ -288,29 +295,30 @@ boxHigherOrderArgs
     -> [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 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 (isLocallyDefined 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
@@ -329,7 +337,7 @@ isFunType var_type
        (_, ty) -> case splitTyConApp_maybe ty of
                        Just (tycon,_) | isFunTyCon tycon -> True
                        _ -> False
-
+#endif
 \end{code}
 
 %************************************************************************