[project @ 1999-11-11 17:50:47 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index e04a4c2..c40320c 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.33 1999/06/24 13:04:17 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.38 1999/11/11 17:50:49 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 )
+import Name            ( Name, isLocalName )
 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
@@ -269,6 +269,7 @@ closureCodeBody binder_info closure_info cc [] body
     cl_descr mod_name = closureDescription mod_name (closureName closure_info)
 
     body_label   = entryLabelFromCI closure_info
+    
     is_box  = case body of { StgApp fun [] -> True; _ -> False }
 
     body_code   = profCtrC SLIT("TICK_ENT_THK") []             `thenC`
@@ -297,6 +298,7 @@ closureCodeBody binder_info closure_info cc all_args body
     -- get the current virtual Sp (it might not be zero, eg. if we're
     -- compiling a let-no-escape).
     getVirtSp `thenFC` \vSp ->
+
     let
        -- Figure out what is needed and what isn't
 
@@ -340,7 +342,9 @@ 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") []            `thenC`
+         = profCtrC SLIT("TICK_ENT_FUN_STD") [
+                   CLbl ticky_ctr_label DataPtrRep
+           ] `thenC`
 
            -- Bind args, and record expected position of stk ptrs
            mapCs bindNewToStack arg_offsets                `thenC`
@@ -371,13 +375,18 @@ closureCodeBody binder_info closure_info cc all_args body
        -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 
        fast_entry_code
-         = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
-                   CLbl (mkRednCountsLabel name) PtrRep,
-                   mkCString (_PK_ (showSDoc (ppr name))),
-                   mkIntCLit stg_arity,        -- total # of args
-                   mkIntCLit sp_stk_args,      -- # passed on stk
-                   mkCString (_PK_ (map (showTypeCategory . idType) all_args))
-               ]                       `thenC`
+         = moduleName          `thenFC` \ mod_name ->
+           profCtrC SLIT("TICK_CTR") [ 
+               CLbl ticky_ctr_label DataPtrRep,
+               mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
+               mkIntCLit stg_arity,    -- total # of args
+               mkIntCLit sp_stk_args,  -- # passed on stk
+               mkCString (_PK_ (map (showTypeCategory . idType) all_args))
+           ] `thenC`
+
+           profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+                   CLbl ticky_ctr_label DataPtrRep
+           ] `thenC`
 
 -- Nuked for now; see comment at end of file
 --                 CString (_PK_ (show_wrapper_name wrapper_maybe)),
@@ -399,24 +408,30 @@ closureCodeBody binder_info closure_info cc all_args body
                -- Do the business
            funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
     in
+
+    setTickyCtrLabel ticky_ctr_label (
+
        -- Make a labelled code-block for the slow and fast entry code
-    forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
+      forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
                                `thenFC` \ slow_abs_c ->
-    forkAbsC fast_entry_code   `thenFC` \ fast_abs_c ->
-    moduleName                 `thenFC` \ mod_name ->
+      forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
+      moduleName                       `thenFC` \ mod_name ->
 
        -- Now either construct the info table, or put the fast code in alone
        -- (We never have slow code without an info table)
        -- XXX probably need the info table and slow entry code in case of
        -- a heap check failure.
-    absC (
-      if info_table_needed then
-       CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+      absC (
+       if info_table_needed then
+         CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
                        (cl_descr mod_name)
-      else
+       else
        CCodeBlock fast_label fast_abs_c
+       )
     )
   where
+    ticky_ctr_label = mkRednCountsLabel name
+
     stg_arity = length all_args
     lf_info = closureLFInfo closure_info
 
@@ -426,6 +441,14 @@ closureCodeBody binder_info closure_info cc all_args body
     name       = closureName closure_info
     fast_label = mkFastEntryLabel name stg_arity
     info_label = mkInfoTableLabel name
+
+
+-- When printing the name of a thing in a ticky file, we want to
+-- 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)))
+  | otherwise       = showSDocDebug (ppr name)
 \end{code}
 
 For lexically scoped profiling we have to load the cost centre from
@@ -538,7 +561,7 @@ argSatisfactionCheck closure_info
 
 \begin{code}
 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
-thunkWrapper closure_info label thunk_code
+thunkWrapper closure_info lbl thunk_code
   =    -- Stack and heap overflow checks
     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 
@@ -554,10 +577,10 @@ thunkWrapper closure_info label thunk_code
       else absC AbsCNop)                       `thenC`
 
         -- stack and/or heap checks
-    thunkChecks label node_points (
+    thunkChecks lbl node_points (
 
        -- Overwrite with black hole if necessary
-    blackHoleIt closure_info node_points       `thenC`
+    blackHoleIt closure_info node_points  `thenC`
 
     setupUpdate closure_info (                 -- setupUpdate *encloses* the rest
 
@@ -604,10 +627,14 @@ blackHoleIt :: ClosureInfo -> Bool -> Code        -- Only called for closures with no a
 blackHoleIt closure_info node_points
   = if blackHoleOnEntry closure_info && node_points
     then
+       let
+         info_label = infoTableLabelFromCI closure_info
+         args = [ CLbl info_label DataPtrRep ]
+       in
        absC (if closureSingleEntry(closure_info) then
-               CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
+               CMacroStmt UPD_BH_SINGLE_ENTRY args
              else
-               CMacroStmt UPD_BH_UPDATABLE [CReg node])
+               CMacroStmt UPD_BH_UPDATABLE args)
     else
        nopC
 \end{code}