[project @ 2003-06-23 11:46:06 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index b6f20a8..a7521a3 100644 (file)
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
-% $Id: CgLetNoEscape.lhs,v 1.11 1998/12/02 13:17:50 simonm Exp $
+% $Id: CgLetNoEscape.lhs,v 1.20 2003/05/14 09:13:56 simonmar Exp $
 %
 %********************************************************
 %*                                                     *
@@ -19,24 +19,28 @@ import {-# SOURCE #-} CgExpr ( cgExpr )
 import StgSyn
 import CgMonad
 import AbsCSyn
-import CLabel          ( CLabel )
 
 import CgBindery       ( letNoEscapeIdInfo, bindArgsToRegs,
                          bindNewToStack, buildContLivenessMask, CgIdInfo,
                          nukeDeadBindings
                        )
-import CgHeapery       ( altHeapCheck )
+import CgHeapery       ( unbxTupleHeapCheck )
 import CgRetConv       ( assignRegs )
-import CgStackery      ( mkTaggedVirtStkOffsets, 
+import CgStackery      ( mkVirtStkOffsets, 
                          allocStackTop, deAllocStackTop, freeStackSlots )
 import CgUsages                ( setRealAndVirtualSp, getRealSp, getSpRelOffset )
-import CLabel          ( mkReturnPtLabel )
+import CLabel          ( mkReturnInfoLabel )
 import ClosureInfo     ( mkLFLetNoEscape )
 import CostCentre       ( CostCentreStack )
-import Id              ( idPrimRep, Id )
+import Name            ( getName )
+import Id              ( Id, idPrimRep, idName )
 import Var             ( idUnique )
-import PrimRep         ( PrimRep(..), retPrimRepSize )
+import PrimRep         ( PrimRep(..), retPrimRepSize, isFollowableRep )
 import BasicTypes      ( RecFlag(..) )
+import Unique          ( Unique )
+import Util            ( splitAtList )
+
+import List            ( partition )
 \end{code}
 
 %************************************************************************
@@ -160,7 +164,6 @@ cgLetNoEscapeClosure
        arity   = length args
        lf_info = mkLFLetNoEscape arity
        uniq    = idUnique binder
-       lbl     = mkReturnPtLabel uniq
     in
 
     -- saveVolatileVarsAndRegs done earlier in cgExpr.
@@ -171,12 +174,12 @@ cgLetNoEscapeClosure
        (allocStackTop retPrimRepSize   `thenFC` \_ ->
         nukeDeadBindings full_live_in_rhss)
 
-       (deAllocStackTop retPrimRepSize   `thenFC` \_ ->
-        buildContLivenessMask uniq       `thenFC` \ liveness ->
-        forkAbsC (cgLetNoEscapeBody binder cc args body lbl) 
+       (deAllocStackTop retPrimRepSize         `thenFC` \_ ->
+        buildContLivenessMask (getName binder) `thenFC` \ liveness ->
+        forkAbsC (cgLetNoEscapeBody binder cc args body uniq) 
                                                `thenFC` \ code ->
-        getSRTLabel                            `thenFC` \ srt_label -> 
-        absC (CRetDirect uniq code (srt_label,srt) liveness)
+        getSRTInfo (idName binder) srt         `thenFC` \ srt_info -> 
+        absC (CRetDirect uniq code srt_info liveness)
                `thenC` returnFC ())
                                        `thenFC` \ (vSp, _) ->
 
@@ -188,32 +191,41 @@ cgLetNoEscapeBody :: Id
                  -> CostCentreStack
                  -> [Id]       -- Args
                  -> StgExpr    -- Body
-                 -> CLabel     -- Entry label
+                 -> Unique     -- Unique for entry label
                  -> Code
 
-cgLetNoEscapeBody binder cc all_args body lbl
+cgLetNoEscapeBody binder cc all_args body uniq
    = 
      -- this is where the stack frame lives:
      getRealSp   `thenFC` \sp -> 
 
+     -- This is very much like bindUnboxedTupleComponents (ToDo)
      let
        arg_kinds            = map idPrimRep all_args
        (arg_regs, _)        = assignRegs [{-nothing live-}] arg_kinds
-       (reg_args, stk_args) = splitAt (length arg_regs) all_args
+       (reg_args, stk_args) = splitAtList arg_regs all_args
+
+       -- separate the rest of the args into pointers and non-pointers
+       ( ptr_args, nptr_args ) = 
+          partition (isFollowableRep . idPrimRep) stk_args
+
+       (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets sp     idPrimRep ptr_args
+       (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_args
 
-       (sp_stk_args, stk_offsets, stk_tags)
-         = mkTaggedVirtStkOffsets sp idPrimRep stk_args
+        ptrs  = ptr_sp - sp
+       nptrs = nptr_sp - ptr_sp
      in
 
        -- Bind args to appropriate regs/stk locns
      bindArgsToRegs reg_args arg_regs              `thenC`
-     mapCs bindNewToStack stk_offsets              `thenC`
-     setRealAndVirtualSp sp_stk_args               `thenC`
+     mapCs bindNewToStack ptr_offsets              `thenC`
+     mapCs bindNewToStack nptr_offsets             `thenC`
 
-       -- free up the stack slots containing tags, and the slot
-       -- containing the return address (really frame header).
-       -- c.f. CgCase.cgUnboxedTupleAlt.
-     freeStackSlots (sp : map fst stk_tags)        `thenC`
+     setRealAndVirtualSp nptr_sp                   `thenC`
+
+       -- free up the stack slots containing the return address
+       -- (frame header itbl).  c.f. CgCase.cgUnboxedTupleAlt.
+     freeStackSlots [sp]                           `thenC`
 
        -- Enter the closures cc, if required
      --enterCostCentreCode closure_info cc IsFunction  `thenC`
@@ -221,13 +233,13 @@ cgLetNoEscapeBody binder cc all_args body lbl
        -- fill in the frame header only if we fail a heap check:
        -- otherwise it isn't needed.
      getSpRelOffset sp                 `thenFC` \sp_rel ->
-     let frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
+     let lbl = mkReturnInfoLabel uniq
+        frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
      in
 
        -- Do heap check [ToDo: omit for non-recursive case by recording in
        --      in envt and absorbing at call site]
-     altHeapCheck False arg_regs stk_tags frame_hdr_asst (Just lbl) (
+     unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst (
        cgExpr body
      )
-
 \end{code}