X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=c1a6ec31d7a1bc865401908f02a4fc6ae7288dfa;hb=084c8a024934d05d39e2c080b00b362605f893b9;hp=96ceff561b5c5819f0f5f2cedc7c1d6c46506770;hpb=f016a43fcbcca53a284e8d6206705ed468a97736;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 96ceff5..c1a6ec3 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.20 1999/05/28 19:24:28 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.25 2000/07/11 16:03:37 simonmar Exp $
 %
 %********************************************************
 %*							*
@@ -28,17 +28,19 @@ module CgTailCall (
 
 import CgMonad
 import AbsCSyn
+import PprAbsC		( pprAmode )
 
-import AbsCUtils	( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import AbsCUtils	( mkAbstractCs, getAmodeRep )
 import CgBindery	( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
 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		( mkUpdInfoLabel, mkRtsPrimOpLabel )
+import CLabel		( mkUpdInfoLabel, mkRtsPrimOpLabel, 
+			  mkBlackHoleInfoTableLabel )
 import ClosureInfo	( nodeMustPointToIt,
 			  getEntryConvention, EntryConvention(..),
 			  LambdaFormInfo
@@ -46,7 +48,6 @@ import ClosureInfo	( nodeMustPointToIt,
 import CmdLineOpts	( opt_DoSemiTagging )
 import Id		( Id, idType, idName )
 import DataCon		( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Const		( mkMachInt )
 import Maybes		( assocMaybe, maybeToBool )
 import PrimRep		( PrimRep(..) )
 import StgSyn		( StgArg, GenStgArg(..) )
@@ -54,6 +55,7 @@ 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 +120,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
@@ -266,8 +269,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,8 +302,8 @@ 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`
 
@@ -423,6 +426,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*
@@ -440,12 +460,14 @@ 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
@@ -458,8 +480,8 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts
 		then nopC
 		else pushReturnAddress eob)		`thenC`
 
-		-- Final adjustment of stack pointer
-	adjustRealSp final_sp		`thenC`
+		-- Final adjustment of Sp/Hp
+	adjustSpAndHp final_sp		`thenC`
 	
 		-- Now decide about semi-tagging
 	let