[project @ 2002-11-19 12:34:55 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 00b1921..edd3402 100644 (file)
--- 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
@@ -169,8 +165,8 @@ stgMassageForProfiling mod_name us stg_binds
     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 (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_`
@@ -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