X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcodeGen%2FCgLetNoEscape.lhs;h=3ea05974f6700542daf87b00f554b2466d86e17e;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=66c46e9f5dc65d6ea10b4411a8bdc2dc3727431e;hpb=0bffc410964e1688ad80d277d53400659e697ab5;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 66c46e9..3ea0597 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.19 2002/12/11 15:36:26 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -18,29 +18,23 @@ import {-# SOURCE #-} CgExpr ( cgExpr )
 
 import StgSyn
 import CgMonad
-import AbsCSyn
 
-import CgBindery	( letNoEscapeIdInfo, bindArgsToRegs,
-			  bindNewToStack, buildContLivenessMask, CgIdInfo,
-			  nukeDeadBindings
-			)
+import CgBindery	( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings	)
+import CgCase		( restoreCurrentCostCentre )
+import CgCon		( bindUnboxedTupleComponents )
 import CgHeapery	( unbxTupleHeapCheck )
-import CgRetConv	( assignRegs )
-import CgStackery	( mkVirtStkOffsets, 
-			  allocStackTop, deAllocStackTop, freeStackSlots )
-import CgUsages		( setRealAndVirtualSp, getRealSp, getSpRelOffset )
+import CgInfoTbls	( emitDirectReturnTarget )
+import CgStackery	( allocStackTop, deAllocStackTop, getSpRelOffset )
+import Cmm		( CmmStmt(..) )
+import CmmUtils		( mkLblExpr, oneStmt )
 import CLabel		( mkReturnInfoLabel )
 import ClosureInfo	( mkLFLetNoEscape )
 import CostCentre       ( CostCentreStack )
-import Name		( getName )
-import Id		( idPrimRep, Id )
+import Id		( Id, idName )
 import Var		( idUnique )
-import PrimRep		( PrimRep(..), retPrimRepSize, isFollowableRep )
+import SMRep		( retAddrSizeW )
 import BasicTypes	( RecFlag(..) )
-import Unique		( Unique )
-import Util		( splitAtList )
-
-import List		( partition )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -158,88 +152,61 @@ cgLetNoEscapeClosure
 -- ToDo: deal with the cost-centre issues
 
 cgLetNoEscapeClosure 
-	binder cc binder_info srt full_live_in_rhss 
+	bndr cc binder_info srt full_live_in_rhss 
 	rhs_eob_info cc_slot rec args body
   = let
 	arity   = length args
 	lf_info = mkLFLetNoEscape arity
-	uniq    = idUnique binder
     in
-
     -- saveVolatileVarsAndRegs done earlier in cgExpr.
 
-    forkEvalHelp
-	rhs_eob_info
+    do  { (vSp, _) <- forkEvalHelp rhs_eob_info
+
+		(do { allocStackTop retAddrSizeW
+		    ; nukeDeadBindings full_live_in_rhss })
 
-	(allocStackTop retPrimRepSize	`thenFC` \_ ->
-	 nukeDeadBindings full_live_in_rhss)
+		(do { deAllocStackTop retAddrSizeW
+		    ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc 
+						  cc_slot args body
 
-	(deAllocStackTop retPrimRepSize		`thenFC` \_ ->
-	 buildContLivenessMask (getName binder)	`thenFC` \ liveness ->
-     	 forkAbsC (cgLetNoEscapeBody binder cc args body uniq) 
-						`thenFC` \ code ->
-	 getSRTInfo srt				`thenFC` \ srt_info -> 
-	 absC (CRetDirect uniq code srt_info liveness)
-		`thenC` returnFC ())
-	    	    	    	     	`thenFC` \ (vSp, _) ->
+			-- Ignore the label that comes back from
+			-- mkRetDirectTarget.  It must be conjured up elswhere
+		    ; emitDirectReturnTarget (idName bndr) abs_c srt
+		    ; return () })
 
-    returnFC (binder, letNoEscapeIdInfo binder vSp lf_info)
+	; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
 \end{code}
 
 \begin{code}
-cgLetNoEscapeBody :: Id
+cgLetNoEscapeBody :: Id		-- Name of the joint point
 		  -> CostCentreStack
+		  -> Maybe VirtualSpOffset
 		  -> [Id]	-- Args
 		  -> StgExpr	-- Body
-		  -> Unique     -- Unique for entry label
 		  -> Code
 
-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) = 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
+cgLetNoEscapeBody bndr cc cc_slot all_args body = do
+  { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args
 
-	(ptr_sp,  ptr_offsets)  = mkVirtStkOffsets sp     idPrimRep ptr_args
-	(nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp idPrimRep nptr_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 ptr_offsets		    `thenC`
-     mapCs bindNewToStack nptr_offsets		    `thenC`
-
-     setRealAndVirtualSp nptr_sp		    `thenC`
-
-	-- free up the stack slots containing the return address
-	-- (frame header itbl).  c.f. CgCase.cgUnboxedTupleAlt.
-     freeStackSlots [sp]			    `thenC`
+     -- restore the saved cost centre.  BUT: we must not free the stack slot
+     -- containing the cost centre, because it might be needed for a
+     -- recursive call to this let-no-escape.
+  ; restoreCurrentCostCentre cc_slot False{-don't free-}
 
 	-- Enter the closures cc, if required
-     --enterCostCentreCode closure_info cc IsFunction  `thenC`
+  ; -- enterCostCentreCode closure_info cc IsFunction
+
+ 	-- The "return address" slot doesn't have a return address in it;
+	-- but the heap-check needs it filled in if the heap-check fails.
+	-- So we pass code to fill it in to the heap-check macro
+  ; sp_rel <- getSpRelOffset ret_slot
 
- 	-- fill in the frame header only if we fail a heap check:
-	-- otherwise it isn't needed.
-     getSpRelOffset sp			`thenFC` \sp_rel ->
-     let lbl = mkReturnInfoLabel uniq
-	 frame_hdr_asst = CAssign (CVal sp_rel RetRep) (CLbl lbl RetRep)
-     in
+  ; let	lbl 	       = mkReturnInfoLabel (idUnique bndr)
+	frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl))
 
 	-- Do heap check [ToDo: omit for non-recursive case by recording in
 	--	in envt and absorbing at call site]
-     unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst (
-	cgExpr body
-     )
+  ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst 
+			(cgExpr body)
+  }
 \end{code}