[project @ 2002-03-26 22:08:44 by sof]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgClosure.lhs

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 8aca152..e7d70e4 100644 (file)
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.52 2001/11/06 11:02:05 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.56 2002/03/14 15:27:17 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -46,7 +46,7 @@ import ClosureInfo    -- lots and lots of stuff
 import CmdLineOpts     ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
 import CostCentre      
 import Id              ( Id, idName, idType, idPrimRep )
-import Name            ( Name, isLocalName )
+import Name            ( Name, isInternalName )
 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
@@ -86,30 +86,18 @@ cgTopRhsClosure id ccs binder_info srt args body lf_info
     let
        name          = idName id
        closure_info  = layOutStaticNoFVClosure name lf_info srt_info
-       closure_label = mkClosureLabel name
+       closure_label = mkClosureLabel name
        cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
     in
 
        -- BUILD THE OBJECT (IF NECESSARY)
-    ({- if staticClosureRequired name binder_info lf_info
-     then -}
-       (if opt_SccProfilingOn 
-         then
-            absC (CStaticClosure
-               closure_label   -- Labelled with the name on lhs of defn
-               closure_info
-               (mkCCostCentreStack ccs)
-               [])             -- No fields
-         else
-            absC (CStaticClosure
-               closure_label   -- Labelled with the name on lhs of defn
-               closure_info
-               (panic "absent cc")
-               [])             -- No fields
-       )
-
-     {- else
+    (
+     ({- if staticClosureRequired name binder_info lf_info
+      then -}
+       absC (mkStaticClosure closure_info ccs [] True)
+      {- else
        nopC -}
+     )
                                                        `thenC`
 
        -- GENERATE THE INFO TABLE (IF NECESSARY)
@@ -273,13 +261,22 @@ closureCodeBody binder_info closure_info cc [] body
     
     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 
-    body_code   = profCtrC SLIT("TICK_ENT_THK") []             `thenC`
+    ticky_ent_lit = if (isStaticClosure closure_info)
+                    then SLIT("TICK_ENT_STATIC_THK")
+                    else SLIT("TICK_ENT_DYN_THK")
+
+    body_code   = profCtrC ticky_ent_lit []                    `thenC`
+                 -- node always points when profiling, so this is ok:
+                 ldvEnter                                      `thenC`
                  thunkWrapper closure_info body_label (
-                       -- We only enter cc after setting up update so that cc
-                       -- of enclosing scope will be recorded in update frame
-                       -- CAF/DICT functions will be subsumed by this enclosing cc
+                       -- We only enter cc after setting up update so
+                       -- that cc of enclosing scope will be recorded
+                       -- in update frame CAF/DICT functions will be
+                       -- subsumed by this enclosing cc
                    enterCostCentreCode closure_info cc IsThunk is_box `thenC`
-                   cgExpr body)
+                   cgExpr body
+                 )
+
 \end{code}
 
 If there is {\em at least one argument}, then this closure is in
@@ -341,7 +338,7 @@ closureCodeBody binder_info closure_info cc all_args body
        --slow_entry_code = forceHeapCheck [] True slow_entry_code'
 
        slow_entry_code
-         = profCtrC SLIT("TICK_ENT_FUN_STD") [
+         = profCtrC slow_ticky_ent_lit [
                    CLbl ticky_ctr_label DataPtrRep
            ] `thenC`
 
@@ -383,7 +380,7 @@ closureCodeBody binder_info closure_info cc all_args body
                        mkCString (_PK_ (map (showTypeCategory . idType) all_args))
                        ] 
                let prof = 
-                       profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+                       profCtrC fast_ticky_ent_lit [
                                CLbl ticky_ctr_label DataPtrRep
                        ] 
 
@@ -432,6 +429,11 @@ closureCodeBody binder_info closure_info cc all_args body
   where
     ticky_ctr_label = mkRednCountsLabel name
 
+    (slow_ticky_ent_lit, fast_ticky_ent_lit) = 
+        if (isStaticClosure closure_info)
+        then (SLIT("TICK_ENT_STATIC_FUN_STD"), SLIT("TICK_ENT_STATIC_FUN_DIRECT"))
+        else (SLIT("TICK_ENT_DYN_FUN_STD"), SLIT("TICK_ENT_DYN_FUN_DIRECT"))
+        
     stg_arity = length all_args
     lf_info = closureLFInfo closure_info
 
@@ -447,7 +449,7 @@ closureCodeBody binder_info closure_info cc all_args body
 -- give the module name even for *local* things.   We print
 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
 ppr_for_ticky_name mod_name name
-  | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
+  | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
   | otherwise       = showSDocDebug (ppr name)
 \end{code}
 
@@ -481,7 +483,7 @@ enterCostCentreCode closure_info ccs is_thunk is_box
            ASSERT(is_thunk == IsFunction)
            costCentresC SLIT("ENTER_CCS_FSUB") []
  
-       else if isCurrentCCS ccs then 
+       else if isDerivedFromCurrentCCS ccs then 
            if re_entrant && not is_box
                then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
                else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
@@ -593,11 +595,14 @@ funWrapper :: ClosureInfo         -- Closure whose code body this is
           -> Code
 funWrapper closure_info arg_regs stk_tags info_label fun_body
   =    -- Stack overflow check
-    nodeMustPointToIt (closureLFInfo closure_info)     `thenFC` \ node_points ->
-    -- HWL   chu' ngoq:
+    nodeMustPointToIt (closureLFInfo closure_info)  `thenFC` \ node_points ->
+
+    -- enter for Ldv profiling
+    (if node_points then ldvEnter else nopC)       `thenC`
+
     (if opt_GranMacros
        then yield arg_regs node_points
-       else absC AbsCNop)                                 `thenC`
+       else absC AbsCNop)                           `thenC`
 
         -- heap and/or stack checks
     fastEntryChecks arg_regs stk_tags info_label node_points (