X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgLetNoEscape.lhs;h=66c46e9f5dc65d6ea10b4411a8bdc2dc3727431e;hb=230850a2290e395b19729f880995e1ede672f80f;hp=b6f20a82905f1aa3469a075ab3a30e757f79e019;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index b6f20a8..66c46e9 100644
--- 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.19 2002/12/11 15:36:26 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 Name		( getName )
 import Id		( idPrimRep, Id )
 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 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}