projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1999-03-22 16:58:19 by simonm]
[ghc-hetmet.git] / ghc / compiler / codeGen / CgClosure.lhs
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 37ee5b3..56a4aeb 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.20 1998/12/02 13:17:47 simonm Exp $
+% $Id: CgClosure.lhs,v 1.26 1999/03/22 16:58:19 simonm Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -48,9 +48,10 @@ import CmdLineOpts   ( opt_GranMacros, opt_SccProfilingOn )
 import CostCentre      
 import Id              ( Id, idName, idType, idPrimRep )
 import Name            ( Name )
+import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
-import Type             ( showTypeCategory )
+import PprType          ( showTypeCategory )
 import Util            ( isIn )
 import CmdLineOpts     ( opt_SccProfilingOn )
 import Outputable
@@ -71,13 +72,12 @@ They should have no free variables.
 cgTopRhsClosure :: Id
                -> CostCentreStack      -- Optional cost centre annotation
                -> StgBinderInfo
-               -> SRT
                -> [Id]         -- Args
                -> StgExpr
                -> LambdaFormInfo
                -> FCode (Id, CgIdInfo)
 
-cgTopRhsClosure id ccs binder_info srt args body lf_info
+cgTopRhsClosure id ccs binder_info args body lf_info
   =    -- LAY OUT THE OBJECT
     let
        closure_info = layOutStaticNoFVClosure name lf_info
@@ -106,7 +106,7 @@ cgTopRhsClosure id ccs binder_info srt args body lf_info
                                                        `thenC`
 
        -- GENERATE THE INFO TABLE (IF NECESSARY)
-    forkClosureBody (closureCodeBody binder_info srt closure_info
+    forkClosureBody (closureCodeBody binder_info closure_info
                                         ccs args body)
 
     ) `thenC`
@@ -131,7 +131,6 @@ cgStdRhsClosure
        :: Id
        -> CostCentreStack      -- Optional cost centre annotation
        -> StgBinderInfo
-       -> SRT                  -- SRT info
        -> [Id]                 -- Free vars
        -> [Id]                 -- Args
        -> StgExpr
@@ -139,7 +138,7 @@ cgStdRhsClosure
        -> [StgArg]             -- payload
        -> FCode (Id, CgIdInfo)
 
-cgStdRhsClosure binder cc binder_info srt fvs args body lf_info payload
+cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
                -- AHA!  A STANDARD-FORM THUNK
   = (
        -- LAY OUT THE OBJECT
@@ -168,14 +167,13 @@ Here's the general case.
 cgRhsClosure   :: Id
                -> CostCentreStack      -- Optional cost centre annotation
                -> StgBinderInfo
-               -> SRT                  -- SRT info
                -> [Id]                 -- Free vars
                -> [Id]                 -- Args
                -> StgExpr
                -> LambdaFormInfo
                -> FCode (Id, CgIdInfo)
 
-cgRhsClosure binder cc binder_info srt fvs args body lf_info
+cgRhsClosure binder cc binder_info fvs args body lf_info
   = (
        -- LAY OUT THE OBJECT
        --
@@ -222,7 +220,7 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info
                nopC)                                   `thenC`
 
                -- Compile the body
-           closureCodeBody binder_info srt closure_info cc args body
+           closureCodeBody binder_info closure_info cc args body
     )  `thenC`
 
        -- BUILD THE OBJECT
@@ -244,7 +242,6 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info
 
 \begin{code}
 closureCodeBody :: StgBinderInfo
-               -> SRT
                -> ClosureInfo     -- Lots of information about this closure
                -> CostCentreStack -- Optional cost centre attached to closure
                -> [Id]
@@ -259,14 +256,13 @@ no argument satisfaction check, so fast and slow entry-point labels
 are the same.
 
 \begin{code}
-closureCodeBody binder_info srt closure_info cc [] body
+closureCodeBody binder_info closure_info cc [] body
   = -- thunks cannot have a primitive type!
     getAbsC body_code  `thenFC` \ body_absC ->
     moduleName         `thenFC` \ mod_name ->
-    getSRTLabel                `thenFC` \ srt_label ->
 
     absC (CClosureInfoAndCode closure_info body_absC Nothing
-                             (srt_label, srt) (cl_descr mod_name))
+                             (cl_descr mod_name))
   where
     cl_descr mod_name = closureDescription mod_name (closureName closure_info)
 
@@ -290,7 +286,7 @@ argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 Node points to closure is available. -- HWL
 
 \begin{code}
-closureCodeBody binder_info srt closure_info cc all_args body
+closureCodeBody binder_info closure_info cc all_args body
   = getEntryConvention name lf_info
                       (map idPrimRep all_args)         `thenFC` \ entry_conv ->
 
@@ -371,12 +367,15 @@ closureCodeBody binder_info srt closure_info cc all_args body
 
        fast_entry_code
          = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
-                   CLbl (mkRednCountsLabel name) PtrRep,
+                   mkIntCLit stg_arity         -- total # of args
+
+               {-  CLbl (mkRednCountsLabel name) PtrRep,
                    CString (_PK_ (showSDoc (ppr name))),
                    mkIntCLit stg_arity,        -- total # of args
                    mkIntCLit sp_stk_args,      -- # passed on stk
                    CString (_PK_ (map (showTypeCategory . idType) all_args)),
                    CString SLIT(""), CString SLIT("")
+               -}
 
 -- Nuked for now; see comment at end of file
 --                 CString (_PK_ (show_wrapper_name wrapper_maybe)),
@@ -404,7 +403,6 @@ closureCodeBody binder_info srt closure_info cc all_args body
                                `thenFC` \ slow_abs_c ->
     forkAbsC fast_entry_code   `thenFC` \ fast_abs_c ->
     moduleName                 `thenFC` \ mod_name ->
-    getSRTLabel                        `thenFC` \ srt_label ->
 
        -- Now either construct the info table, or put the fast code in alone
        -- (We never have slow code without an info table)
@@ -413,7 +411,7 @@ closureCodeBody binder_info srt closure_info cc all_args body
     absC (
       if info_table_needed then
        CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
-                       (srt_label, srt) (cl_descr mod_name)
+                       (cl_descr mod_name)
       else
        CCodeBlock fast_label fast_abs_c
     )
@@ -438,9 +436,9 @@ Node is guaranteed to point to it, if profiling and not inherited.
 
 \begin{code}
 data IsThunk = IsThunk | IsFunction -- Bool-like, local
---#ifdef DEBUG
+-- #ifdef DEBUG
        deriving Eq
---#endif
+-- #endif
 
 enterCostCentreCode :: ClosureInfo -> CostCentreStack -> IsThunk -> Code
 
@@ -459,14 +457,16 @@ enterCostCentreCode closure_info ccs is_thunk
            costCentresC SLIT("ENTER_CCS_FSUB") []
 
        else if isCurrentCCS ccs then 
-           -- get CCC out of the closure, where we put it when we alloc'd
-           case is_thunk of 
-               IsThunk    -> costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
-               IsFunction -> costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
+           if re_entrant 
+               then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
+               else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
 
        else if isCafCCS ccs && isToplevClosure closure_info then
            ASSERT(is_thunk == IsThunk)
-           costCentresC SLIT("ENTER_CCS_CAF") c_ccs
+               -- might be a PAP, in which case we want to subsume costs
+           if re_entrant
+               then costCentresC SLIT("ENTER_CCS_FSUB") []
+               else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
 
        else -- we've got a "real" cost centre right here in our hands...
            case is_thunk of 
@@ -476,6 +476,7 @@ enterCostCentreCode closure_info ccs is_thunk
                              else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs
    where
        c_ccs = [mkCCostCentreStack ccs]
+       re_entrant = closureReEntrant closure_info
 \end{code}
 
 %************************************************************************
@@ -663,7 +664,7 @@ Otherwise it is determind by @closureDescription@ from the let
 binding information.
 
 \begin{code}
-closureDescription :: FAST_STRING      -- Module
+closureDescription :: Module           -- Module
                   -> Name              -- Id of closure binding
                   -> String
 
@@ -673,7 +674,7 @@ closureDescription :: FAST_STRING   -- Module
 closureDescription mod_name name
   = showSDoc (
        hcat [char '<',
-                  ptext mod_name,
+                  pprModule mod_name,
                   char '.',
                   ppr name,
                   char '>'])
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)