[project @ 2001-09-26 15:11:50 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 6f139b1..ea8f34c 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.44 2000/12/06 13:19:49 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.49 2001/09/26 15:11:50 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -45,14 +45,14 @@ import CLabel               ( CLabel, mkClosureLabel, mkFastEntryLabel,
 import ClosureInfo     -- lots and lots of stuff
 import CmdLineOpts     ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
 import CostCentre      
-import Id              ( Id, idName, idType, idPrimRep, setIdName )
-import Name            ( Name, isLocalName, globaliseName )
+import Id              ( Id, idName, idType, idPrimRep )
+import Name            ( Name, isLocalName )
 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
 import PprType          ( showTypeCategory )
 import Util            ( isIn )
-import CmdLineOpts     ( opt_SccProfilingOn, opt_EnsureSplittableC )
+import CmdLineOpts     ( opt_SccProfilingOn )
 import Outputable
 
 import Name             ( nameOccName )
@@ -73,17 +73,19 @@ 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 args body lf_info
+cgTopRhsClosure id ccs binder_info srt args body lf_info
   = 
     -- LAY OUT THE OBJECT
+    getSRTInfo srt             `thenFC` \ srt_info ->
     let
        name          = idName id
-       closure_info  = layOutStaticNoFVClosure name lf_info
+       closure_info  = layOutStaticNoFVClosure name lf_info srt_info
        closure_label = mkClosureLabel name
        cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
     in
@@ -147,7 +149,8 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
     getArgAmodes payload                       `thenFC` \ amodes ->
     let
        (closure_info, amodes_w_offsets)
-         = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
+         = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT
+               -- No SRT for a standard-form closure
 
        (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
     in
@@ -166,13 +169,14 @@ Here's the general case.
 cgRhsClosure   :: Id
                -> CostCentreStack      -- Optional cost centre annotation
                -> StgBinderInfo
+               -> SRT
                -> [Id]                 -- Free vars
                -> [Id]                 -- Args
                -> StgExpr
                -> LambdaFormInfo
                -> FCode (Id, CgIdInfo)
 
-cgRhsClosure binder cc binder_info fvs args body lf_info
+cgRhsClosure binder cc binder_info srt fvs args body lf_info
   = (
        -- LAY OUT THE OBJECT
        --
@@ -192,12 +196,14 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
                         else fvs
     in
     mapFCs getCAddrModeAndInfo reduced_fvs     `thenFC` \ fvs_w_amodes_and_info ->
+    getSRTInfo srt                             `thenFC` \ srt_info ->
     let
        closure_info :: ClosureInfo
        bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
 
        (closure_info, bind_details)
-         = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
+         = layOutDynClosure (idName binder) get_kind
+                            fvs_w_amodes_and_info lf_info srt_info
 
        bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
 
@@ -320,12 +326,7 @@ closureCodeBody binder_info closure_info cc all_args body
        --
        arg_regs = case entry_conv of
                DirectEntry lbl arity regs -> regs
-               other                      -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") []
-
-        pprHWL :: EntryConvention -> String    
-        pprHWL (ViaNode) = "ViaNode"
-        pprHWL (StdEntry cl) = "StdEntry"
-        pprHWL (DirectEntry cl i l) = "DirectEntry"
+               other                      -> []  -- "(HWL ignored; no args passed in regs)"
 
        num_arg_regs = length arg_regs
        
@@ -374,19 +375,19 @@ closureCodeBody binder_info closure_info cc all_args body
        -- see argSatisfactionCheck for new version
        -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
 
-       fast_entry_code
-         = 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`
+       fast_entry_code = do
+               mod_name <- moduleName
+               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))
+                       ] 
+               let prof = 
+                       profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
+                               CLbl ticky_ctr_label DataPtrRep
+                       ] 
 
 -- Nuked for now; see comment at end of file
 --                 CString (_PK_ (show_wrapper_name wrapper_maybe)),
@@ -395,18 +396,19 @@ closureCodeBody binder_info closure_info cc all_args body
 
                -- Bind args to regs/stack as appropriate, and
                -- record expected position of sps.
-           bindArgsToRegs reg_args arg_regs                `thenC`
-           mapCs bindNewToStack stk_offsets                `thenC`
-           setRealAndVirtualSp sp_stk_args                 `thenC`
+               bindArgsToRegs reg_args arg_regs                    
+               mapCs bindNewToStack stk_offsets                    
+               setRealAndVirtualSp sp_stk_args             
 
                -- free up the stack slots containing tags
-           freeStackSlots (map fst stk_tags)               `thenC`
+               freeStackSlots (map fst stk_tags)
 
                -- Enter the closures cc, if required
-           enterCostCentreCode closure_info cc IsFunction False `thenC`
+               enterCostCentreCode closure_info cc IsFunction False
 
                -- Do the business
-           funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
+               funWrapper closure_info arg_regs stk_tags info_label 
+                       (prof >> cgExpr body)
     in
 
     setTickyCtrLabel ticky_ctr_label (
@@ -415,7 +417,7 @@ closureCodeBody binder_info closure_info cc all_args body
       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 ->
+      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)