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

diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index c3ee85b..3ea0597 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -1,5 +1,7 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -8,30 +10,31 @@
 %********************************************************
 
 \begin{code}
-#include "HsVersions.h"
-
 module CgLetNoEscape ( cgLetNoEscapeClosure ) where
 
-IMP_Ubiq(){-uitious-}
-IMPORT_DELOOPER(CgLoop2)		( cgExpr )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} CgExpr ( cgExpr )
 
 import StgSyn
 import CgMonad
-import AbsCSyn
-
-import CgBindery	( letNoEscapeIdInfo, bindArgsToRegs,
-			  bindNewToAStack, bindNewToBStack,
-			  CgIdInfo
-			)
-import CgHeapery	( heapCheck )
-import CgRetConv	( assignRegs )
-import CgStackery	( mkVirtStkOffsets )
-import CgUsages		( setRealAndVirtualSps, getVirtSps )
-import CLabel		( mkStdEntryLabel )
+
+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       ( CostCentre )
-import HeapOffs		( SYN_IE(VirtualSpBOffset) )
-import Id		( idPrimRep, SYN_IE(Id) )
+import CostCentre       ( CostCentreStack )
+import Id		( Id, idName )
+import Var		( idUnique )
+import SMRep		( retAddrSizeW )
+import BasicTypes	( RecFlag(..) )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -50,7 +53,7 @@ Consider:
 		if ... then x else ...
 \end{verbatim}
 @x@ is used twice (so we probably can't unfold it), but when it is
-entered, the stack is deeper than it was then the definition of @x@
+entered, the stack is deeper than it was when the definition of @x@
 happened.  Specifically, if instead of allocating a closure for @x@,
 we saved all @x@'s fvs on the stack, and remembered the stack depth at
 that moment, then whenever we enter @x@ we can simply set the stack
@@ -134,75 +137,76 @@ on the stack, if they aren't there already.
 \begin{code}
 cgLetNoEscapeClosure
 	:: Id			-- binder
-	-> CostCentre 	   	-- NB: *** NOT USED *** ToDo (WDP 94/06)
+	-> CostCentreStack   	-- NB: *** NOT USED *** ToDo (WDP 94/06)
 	-> StgBinderInfo	-- NB: ditto
-	-> StgLiveVars	-- variables live in RHS, including the binders
+	-> SRT
+	-> StgLiveVars		-- variables live in RHS, including the binders
 				-- themselves in the case of a recursive group
 	-> EndOfBlockInfo       -- where are we going to?
-	-> Maybe VirtualSpBOffset -- Slot for current cost centre
+	-> Maybe VirtualSpOffset -- Slot for current cost centre
+	-> RecFlag		-- is the binding recursive?
 	-> [Id]			-- args (as in \ args -> body)
     	-> StgExpr		-- body (as in above)
 	-> FCode (Id, CgIdInfo)
 
 -- ToDo: deal with the cost-centre issues
 
-cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info maybe_cc_slot args body
+cgLetNoEscapeClosure 
+	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 full_live_in_rhss{-used???-}
+	lf_info = mkLFLetNoEscape arity
     in
-    forkEvalHelp
-	rhs_eob_info
-	(nukeDeadBindings full_live_in_rhss)
-	(forkAbsC (cgLetNoEscapeBody args body))
-	    	    	    	     	`thenFC` \ (vA, vB, code) ->
-    let
-	label = mkStdEntryLabel binder -- arity
-    in
-    absC (CCodeBlock label code) `thenC`
-    returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
+    -- saveVolatileVarsAndRegs done earlier in cgExpr.
+
+    do  { (vSp, _) <- forkEvalHelp rhs_eob_info
+
+		(do { allocStackTop retAddrSizeW
+		    ; nukeDeadBindings full_live_in_rhss })
+
+		(do { deAllocStackTop retAddrSizeW
+		    ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc 
+						  cc_slot args body
+
+			-- 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]		-- Args
+cgLetNoEscapeBody :: Id		-- Name of the joint point
+		  -> CostCentreStack
+		  -> Maybe VirtualSpOffset
+		  -> [Id]	-- Args
 		  -> StgExpr	-- Body
 		  -> Code
 
-cgLetNoEscapeBody all_args rhs
-  = getVirtSps		`thenFC` \ (vA, vB) ->
-    let
-	arg_kinds	     = map idPrimRep all_args
-	(arg_regs, _)	     = assignRegs [{-nothing live-}] arg_kinds
-	(reg_args, stk_args) = splitAt (length arg_regs) all_args
-
-    	-- stk_args is the args which are passed on the stack at the fast-entry point
-    	-- Using them, we define the stack layout
-    	(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
-	  = mkVirtStkOffsets
-		vA vB 		-- Initial virtual SpA, SpB
-		idPrimRep
-		stk_args
-    in
+cgLetNoEscapeBody bndr cc cc_slot all_args body = do
+  { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args
 
-	-- Bind args to appropriate regs/stk locns
-    bindArgsToRegs reg_args arg_regs		    `thenC`
-    mapCs bindNewToAStack stk_bxd_w_offsets	    `thenC`
-    mapCs bindNewToBStack stk_ubxd_w_offsets	    `thenC`
-    setRealAndVirtualSps spA_stk_args spB_stk_args  `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-}
 
-{- 	ToDo: NOT SURE ABOUT COST CENTRES!
 	-- Enter the closures cc, if required
-	lexEnterCCcode closure_info maybe_cc  	    `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
 
-	-- [No need for stack check; forkEvalHelp dealt with that]
+  ; 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]
-    heapCheck arg_regs False {- Node doesn't point to it -}  (
-	      -- heapCheck *encloses* the rest
-
-	-- Compile the body
-    cgExpr rhs
-    )
+  ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst 
+			(cgExpr body)
+  }
 \end{code}