[project @ 2000-10-24 08:40:09 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 c40320c..b2bd1fe 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.38 1999/11/11 17:50:49 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.42 2000/10/24 08:40:09 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -57,7 +57,8 @@ import Outputable
 
 import Name             ( nameOccName )
 import OccName          ( occNameFS )
-
+import FastTypes       ( iBox )
+       
 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
 \end{code}
 
@@ -158,9 +159,6 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
 
        -- RETURN
     returnFC (binder, heapIdInfo binder heap_offset lf_info)
-
-  where
-    is_std_thunk          = isStandardFormThunk lf_info
 \end{code}
 
 Here's the general case.
@@ -311,7 +309,7 @@ closureCodeBody binder_info closure_info cc all_args body
 
        -- Arg mapping for standard (slow) entry point; all args on stack,
        -- with tagging.
-       (sp_all_args, arg_offsets, arg_tags)
+       (sp_all_args, arg_offsets, _)
           = mkTaggedVirtStkOffsets vSp idPrimRep all_args
 
        -- Arg mapping for the fast entry point; as many args as poss in
@@ -325,7 +323,12 @@ closureCodeBody binder_info closure_info cc all_args body
        --
        arg_regs = case entry_conv of
                DirectEntry lbl arity regs -> regs
-               other                       -> panic "closureCodeBody:arg_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"
 
        num_arg_regs = length arg_regs
        
@@ -350,7 +353,7 @@ closureCodeBody binder_info closure_info cc all_args body
            mapCs bindNewToStack arg_offsets                `thenC`
            setRealAndVirtualSp sp_all_args                 `thenC`
 
-           argSatisfactionCheck closure_info               `thenC`
+           argSatisfactionCheck closure_info   arg_regs            `thenC`
 
            -- OK, so there are enough args.  Now we need to stuff as
            -- many of them in registers as the fast-entry code
@@ -516,28 +519,28 @@ relative offset of this word tells how many words of arguments
 are expected.
 
 \begin{code}
-argSatisfactionCheck :: ClosureInfo -> Code
+argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
 
-argSatisfactionCheck closure_info
+argSatisfactionCheck closure_info arg_regs
 
   = nodeMustPointToIt (closureLFInfo closure_info)   `thenFC` \ node_points ->
 
-    let
-       emit_gran_macros = opt_GranMacros
-    in
+--      let
+--         emit_gran_macros = opt_GranMacros
+--      in
 
     -- HWL  ngo' ngoq:
     -- absC (CMacroStmt GRAN_FETCH [])                         `thenC`
     -- forceHeapCheck [] node_points (absC AbsCNop)                    `thenC`
-    (if emit_gran_macros 
-      then if node_points 
-             then fetchAndReschedule  [] node_points 
-             else yield [] node_points
-      else absC AbsCNop)                       `thenC`
+    --(if opt_GranMacros
+    --  then if node_points 
+    --         then fetchAndReschedule  arg_regs node_points 
+    --         else yield arg_regs node_points
+    --  else absC AbsCNop)                       `thenC`
 
         getSpRelOffset 0       `thenFC` \ (SpRel sp) ->
        let
-           off = I# sp
+           off     = iBox sp
            rel_arg = mkIntCLit off
        in
        ASSERT(off /= 0)
@@ -565,16 +568,13 @@ thunkWrapper closure_info lbl thunk_code
   =    -- Stack and heap overflow checks
     nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
 
-    let
-       emit_gran_macros = opt_GranMacros
-    in
-       -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-       -- (we prefer fetchAndReschedule-style context switches to yield ones)
-    (if emit_gran_macros 
-      then if node_points 
-             then fetchAndReschedule  [] node_points 
-             else yield [] node_points
-      else absC AbsCNop)                       `thenC`
+    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+    -- (we prefer fetchAndReschedule-style context switches to yield ones)
+    (if opt_GranMacros
+       then if node_points 
+              then fetchAndReschedule [] node_points 
+              else yield [] node_points
+       else absC AbsCNop)                       `thenC`
 
         -- stack and/or heap checks
     thunkChecks lbl node_points (
@@ -597,13 +597,10 @@ funWrapper :: ClosureInfo         -- Closure whose code body this is
 funWrapper closure_info arg_regs stk_tags info_label fun_body
   =    -- Stack overflow check
     nodeMustPointToIt (closureLFInfo closure_info)     `thenFC` \ node_points ->
-    let
-       emit_gran_macros = opt_GranMacros
-    in
     -- HWL   chu' ngoq:
-    (if emit_gran_macros
-      then yield  arg_regs node_points
-      else absC AbsCNop)                                 `thenC`
+    (if opt_GranMacros
+       then yield arg_regs node_points
+       else absC AbsCNop)                                 `thenC`
 
         -- heap and/or stack checks
     fastEntryChecks arg_regs stk_tags info_label node_points (
@@ -682,9 +679,8 @@ setupUpdate closure_info code
        -- updated with the new value when available.
 
              -- Alloc black hole specifying CC_HDR(Node) as the cost centre
-             --   Hack Warning: Using a CLitLit to get CAddrMode !
        let
-           use_cc   = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
+           use_cc   = CMacroExpr PtrRep CCS_HDR [nodeReg]
            blame_cc = use_cc
        in
        allocDynClosure (bhCI closure_info) use_cc blame_cc []  `thenFC` \ heap_offset ->