X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgLetNoEscape.lhs;h=3ea05974f6700542daf87b00f554b2466d86e17e;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=8562b678b0bc0cb3255fe337c39e7b9503ad11a0;hpb=9e93335020e64a811dbbb223e1727c76933a93ae;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 8562b67..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.16 2001/10/25 02:13:11 sof Exp $
+% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -18,26 +18,23 @@ import {-# SOURCE #-} CgExpr ( cgExpr )
 
 import StgSyn
 import CgMonad
-import AbsCSyn
-
-import CgBindery	( letNoEscapeIdInfo, bindArgsToRegs,
-			  bindNewToStack, buildContLivenessMask, CgIdInfo,
-			  nukeDeadBindings
-			)
-import CgHeapery	( altHeapCheck )
-import CgRetConv	( assignRegs )
-import CgStackery	( mkTaggedVirtStkOffsets, 
-			  allocStackTop, deAllocStackTop, freeStackSlots )
-import CgUsages		( setRealAndVirtualSp, getRealSp, getSpRelOffset )
+
+import CgBindery	( CgIdInfo, letNoEscapeIdInfo, nukeDeadBindings	)
+import CgCase		( restoreCurrentCostCentre )
+import CgCon		( bindUnboxedTupleComponents )
+import CgHeapery	( unbxTupleHeapCheck )
+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 Id		( idPrimRep, Id )
+import Id		( Id, idName )
 import Var		( idUnique )
-import PrimRep		( PrimRep(..), retPrimRepSize )
+import SMRep		( retAddrSizeW )
 import BasicTypes	( RecFlag(..) )
-import Unique		( Unique )
-import Util		( splitAtList )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -155,80 +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
 
-	(allocStackTop retPrimRepSize	`thenFC` \_ ->
-	 nukeDeadBindings full_live_in_rhss)
+		(do { allocStackTop retAddrSizeW
+		    ; nukeDeadBindings full_live_in_rhss })
 
-	(deAllocStackTop retPrimRepSize		`thenFC` \_ ->
-	 buildContLivenessMask uniq		`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, _) ->
+		(do { deAllocStackTop retAddrSizeW
+		    ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc 
+						  cc_slot args body
 
-    returnFC (binder, letNoEscapeIdInfo binder vSp lf_info)
+			-- Ignore the label that comes back from
+			-- mkRetDirectTarget.  It must be conjured up elswhere
+		    ; emitDirectReturnTarget (idName bndr) abs_c srt
+		    ; return () })
+
+	; 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 -> 
-
-     let
-	arg_kinds	     = map idPrimRep all_args
-	(arg_regs, _)	     = assignRegs [{-nothing live-}] arg_kinds
-	(reg_args, stk_args) = splitAtList arg_regs all_args
+cgLetNoEscapeBody bndr cc cc_slot all_args body = do
+  { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args
 
-    	(sp_stk_args, stk_offsets, stk_tags)
-	  = mkTaggedVirtStkOffsets sp idPrimRep stk_args
-     in
-
-	-- Bind args to appropriate regs/stk locns
-     bindArgsToRegs reg_args arg_regs		    `thenC`
-     mapCs bindNewToStack stk_offsets		    `thenC`
-     setRealAndVirtualSp sp_stk_args		    `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`
+     -- 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
 
- 	-- 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
+ 	-- 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
+
+  ; 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]
-     altHeapCheck False arg_regs stk_tags frame_hdr_asst (Just uniq) (
-	cgExpr body
-     )
-
+  ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst 
+			(cgExpr body)
+  }
 \end{code}