X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=46e3b0219f8beaf623fdfae7fecd216fb1861be3;hb=de896403dfe48bc999e5501eb8b517624dd2e5d4;hp=772d2fef7ce583f002814c6ae79091fd8e656cfe;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 772d2fe..46e3b02 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgTailCall.lhs,v 1.17 1998/12/18 17:40:53 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.23 1999/11/02 15:05:43 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -28,6 +28,7 @@ module CgTailCall (
 
 import CgMonad
 import AbsCSyn
+import PprAbsC		( pprAmode )
 
 import AbsCUtils	( mkAbstractCs, mkAbsCStmts, getAmodeRep )
 import CgBindery	( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
@@ -35,10 +36,11 @@ import CgRetConv	( dataReturnConvPrim,
 			  ctrlReturnConvAlg, CtrlReturnConvention(..),
 			  assignAllRegs, assignRegs
 			)
-import CgStackery	( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
-import CgUsages		( getSpRelOffset )
+import CgStackery	( mkTaggedStkAmodes, adjustStackHW )
+import CgUsages		( getSpRelOffset, adjustSpAndHp )
 import CgUpdate		( pushSeqFrame )
-import CLabel		( mkUpdEntryLabel, mkRtsPrimOpLabel )
+import CLabel		( mkUpdInfoLabel, mkRtsPrimOpLabel, 
+			  mkBlackHoleInfoTableLabel )
 import ClosureInfo	( nodeMustPointToIt,
 			  getEntryConvention, EntryConvention(..),
 			  LambdaFormInfo
@@ -47,13 +49,14 @@ import CmdLineOpts	( opt_DoSemiTagging )
 import Id		( Id, idType, idName )
 import DataCon		( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
 import Const		( mkMachInt )
-import Maybes		( assocMaybe )
+import Maybes		( assocMaybe, maybeToBool )
 import PrimRep		( PrimRep(..) )
 import StgSyn		( StgArg, GenStgArg(..) )
 import Type		( isUnLiftedType )
 import TyCon            ( TyCon )
 import PrimOp		( PrimOp )
 import Util		( zipWithEqual )
+import Unique		( mkPseudoUnique1 )
 import Outputable
 import Panic		( panic, assertPanic )
 \end{code}
@@ -118,7 +121,8 @@ performPrimReturn :: SDoc	-- Just for debugging (sigh)
 performPrimReturn doc amode
   = let
 	kind = getAmodeRep amode
-	ret_reg = dataReturnConvPrim kind
+	ret_reg = WARN( case kind of { PtrRep -> True; other -> False }, text "primRet" <+> doc <+> pprAmode amode )
+		  dataReturnConvPrim kind
 
 	assign_possibly = case kind of
 	  VoidRep -> AbsCNop
@@ -168,7 +172,7 @@ mkStaticAlgReturnCode con sequel
 	UpdateCode ->	-- Ha!  We can go direct to the update code,
 			-- (making sure to jump to the *correct* update
 			--  code.)
-    			absC (CReturn (CLbl mkUpdEntryLabel CodePtrRep)
+    			absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
 				      return_info)
 
 	CaseAlts _ (Just (alts, _)) ->	-- Ho! We know the constructor so
@@ -266,8 +270,8 @@ performReturn sim_assts finish_code
 	--  stack location)
     pushReturnAddress eob		`thenC`
 
-	-- Adjust stack pointer
-    adjustRealSp args_sp		`thenC`
+	-- Adjust Sp/Hp
+    adjustSpAndHp args_sp		`thenC`
 
 	-- Do the return
     finish_code sequel		-- "sequel" is `robust' in that it doesn't
@@ -299,14 +303,16 @@ returnUnboxedTuple amodes before_jump
     pushReturnAddress eob		`thenC`
     setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
 
-	-- Adjust stack pointer
-    adjustRealSp args_sp		`thenC`
+	-- Adjust Sp/Hp
+    adjustSpAndHp args_sp		`thenC`
 
     before_jump				`thenC`
 
     let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
     in
 
+    profCtrC SLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
+
     doTailCall amodes ret_regs
 		mkUnboxedTupleReturnCode
 		(length leftovers)  {- fast args arity -}
@@ -388,7 +394,8 @@ doTailCall
 	-> (Sequel->Code)		-- code to perform jump
 	-> Int				-- number of "fast" stack arguments
 	-> AbstractC			-- pending assignments
-	-> Maybe VirtualSpOffset	-- sp offset to trim stack to
+	-> Maybe VirtualSpOffset	-- sp offset to trim stack to: 
+					-- USED iff destination is a let-no-escape
 	-> Bool				-- node points to the closure to enter
 	-> Code
 
@@ -420,6 +427,23 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
 
 	(fast_stk_amodes, tagged_stk_amodes) = 
 		splitAt arity stk_arg_amodes
+
+	-- eager blackholing, at the end of the basic block.
+	node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
+	(r1_tmp_asst, bh_asst)
+	 = case sequel of
+#if 0
+	-- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
+	-- we might be in a case continuation later down the line.  Also,
+	-- we might have pushed a return address on the stack, if we're in
+	-- a case scrut, and still be in the thunk's entry code.
+		UpdateCode -> 
+		   (CAssign node_save nodeReg,
+		    CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep) 
+				  PtrRep)
+			    (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
+#endif
+		_ -> (AbsCNop, AbsCNop)
     in
 	-- We can omit tags on the arguments passed to the fast entry point, 
 	-- but we have to be careful to fill in the tags on any *extra*
@@ -437,20 +461,28 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
 		-- The stack space for the pushed return addess, 
 		-- with any args pushed on top, is recorded in final_sp.
 	
-		-- Do the simultaneous assignments,
-	doSimAssts (mkAbstractCs [pending_assts,
+			-- Do the simultaneous assignments,
+	doSimAssts (mkAbstractCs [r1_tmp_asst,
+				  pending_assts,
 			          reg_arg_assts, 
 				  fast_arg_assts, 
 				  tagged_arg_assts,
 			          tag_assts])	`thenC`
+	absC bh_asst `thenC`
 	
 		-- push a return address if necessary
 		-- (after the assignments above, in case we clobber a live
 		--  stack location)
-	pushReturnAddress eob		`thenC`
 
-		-- Final adjustment of stack pointer
-	adjustRealSp final_sp		`thenC`
+		-- DONT push the return address when we're about
+		-- to jump to a let-no-escape: the final tail call
+		-- in the let-no-escape will do this.
+	(if (maybeToBool maybe_join_sp)
+		then nopC
+		else pushReturnAddress eob)		`thenC`
+
+		-- Final adjustment of Sp/Hp
+	adjustSpAndHp final_sp		`thenC`
 	
 		-- Now decide about semi-tagging
 	let