X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTailCall.lhs;h=22cecb72492bfd93a51a0ff71aef4847f70dc1e2;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hp=56614a87f3d7fe17a8077a1abeaadd8b24b38e12;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 56614a8..22cecb7 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -1,19 +1,13 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgTailCall.lhs,v 1.43 2005/06/21 10:44:41 simonmar Exp $
-%
-%********************************************************
-%*							*
-\section[CgTailCall]{Tail calls: converting @StgApps@}
-%*							*
-%********************************************************
+% Code generation for tail calls.
 
 \begin{code}
 module CgTailCall (
 	cgTailCall, performTailCall,
 	performReturn, performPrimReturn,
-	emitKnownConReturnCode, emitAlgReturnCode,
 	returnUnboxedTuple, ccallReturnUnboxedTuple,
 	pushUnboxedTuple,
 	tailCallPrimOp,
@@ -24,31 +18,25 @@ module CgTailCall (
 #include "HsVersions.h"
 
 import CgMonad
-import CgBindery	( getArgAmodes, getCgIdInfo, CgIdInfo, maybeLetNoEscape,
-			  idInfoToAmode, cgIdInfoId, cgIdInfoLF,
-			  cgIdInfoArgRep )
-import CgInfoTbls	( entryCode, emitDirectReturnInstr, dataConTagZ,
-			  emitVectoredReturnInstr, closureInfoPtr )
+import CgBindery
+import CgInfoTbls
 import CgCallConv
-import CgStackery	( setRealSp, mkStkAmodes, adjustStackHW,
-			  getSpRelOffset )
-import CgHeapery	( setRealHp, getHpRelOffset )
-import CgUtils		( emitSimultaneously )
+import CgStackery
+import CgHeapery
+import CgUtils
 import CgTicky
 import ClosureInfo
-import SMRep		( CgRep, isVoidArg, separateByPtrFollowness )
+import SMRep
 import Cmm	
 import CmmUtils
-import CLabel		( CLabel, mkRtsPrimOpLabel, mkSeqInfoLabel )
-import Type		( isUnLiftedType )
-import Id		( Id, idName, idUnique, idType )
-import DataCon		( DataCon, dataConTyCon )
-import StgSyn		( StgArg )
-import TyCon            ( TyCon )
-import PrimOp		( PrimOp )
+import CLabel
+import Type
+import Id
+import StgSyn
+import PrimOp
 import Outputable
 
-import Monad		( when )
+import Control.Monad
 
 -----------------------------------------------------------------------------
 -- Tail Calls
@@ -133,14 +121,14 @@ performTailCall fun_info arg_amodes pending_assts
 	    -- As with any return, Node must point to it.
 	    ReturnIt -> do
 		{ emitSimultaneously (node_asst `plusStmts` pending_assts)
-		; doFinalJump sp False emitDirectReturnInstr }
+		; doFinalJump sp False emitReturnInstr }
     
 	    -- A real constructor.  Don't bother entering it, 
 	    -- just do the right sort of return instead.
 	    -- As with any return, Node must point to it.
 	    ReturnCon con -> do
 		{ emitSimultaneously (node_asst `plusStmts` pending_assts)
-		; doFinalJump sp False (emitKnownConReturnCode con) }
+		; doFinalJump sp False emitReturnInstr }
 
 	    JumpToIt lbl -> do
 		{ emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
@@ -227,17 +215,17 @@ doFinalJump final_sp is_let_no_escape jump_code
 	    -- and do the jump
 	; jump_code }
 
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
 -- A general return (just a special case of doFinalJump, above)
 
-performReturn :: Code		-- The code to execute to actually do the return
+performReturn :: Code	-- The code to execute to actually do the return
 	      -> Code
 
 performReturn finish_code
   = do  { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo
 	; doFinalJump args_sp False{-not a LNE-} finish_code }
 
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
 -- Primitive Returns
 -- Just load the return value into the right register, and return.
 
@@ -246,34 +234,10 @@ performPrimReturn :: CgRep -> CmmExpr	-- The thing to return
 performPrimReturn rep amode
   =  do { whenC (not (isVoidArg rep))
 		(stmtC (CmmAssign ret_reg amode))
-	; performReturn emitDirectReturnInstr }
+	; performReturn emitReturnInstr }
   where
     ret_reg = dataReturnConvPrim rep
 
--- -----------------------------------------------------------------------------
--- Algebraic constructor returns
-
--- Constructor is built on the heap; Node is set.
--- All that remains is to do the right sort of jump.
-
-emitKnownConReturnCode :: DataCon -> Code
-emitKnownConReturnCode con
-  = emitAlgReturnCode (dataConTyCon con)
-		      (CmmLit (mkIntCLit (dataConTagZ con)))
-			-- emitAlgReturnCode requires zero-indexed tag
-
-emitAlgReturnCode :: TyCon -> CmmExpr -> Code
--- emitAlgReturnCode is used both by emitKnownConReturnCode,
--- and by by PrimOps that return enumerated types (i.e.
--- all the comparison operators).
-emitAlgReturnCode tycon tag
- =  do	{ case ctrlReturnConvAlg tycon of
-	    VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz
-	 			     	; emitVectoredReturnInstr tag }
-	    UnvectoredReturn _    -> emitDirectReturnInstr 
-	}
-
-
 -- ---------------------------------------------------------------------------
 -- Unboxed tuple returns
 
@@ -294,7 +258,7 @@ returnUnboxedTuple amodes
 	; tickyUnboxedTupleReturn (length amodes)
 	; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
 	; emitSimultaneously assts
-	; doFinalJump final_sp False{-not a LNE-} emitDirectReturnInstr }
+	; doFinalJump final_sp False{-not a LNE-} emitReturnInstr }
 
 pushUnboxedTuple :: VirtualSpOffset		-- Sp at which to start pushing
 		 -> [(CgRep, CmmExpr)]		-- amodes of the components
@@ -384,19 +348,10 @@ tailCallPrimOp op args
 
 pushReturnAddress :: EndOfBlockInfo -> Code
 
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False))
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _))
   = do	{ sp_rel <- getSpRelOffset args_sp
 	; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
 
--- For a polymorphic case, we have two return addresses to push: the case
--- return, and stg_seq_frame_info which turns a possible vectored return
--- into a direct one.
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ True))
-  = do	{ sp_rel <- getSpRelOffset (args_sp-1)
-	; stmtC (CmmStore sp_rel (mkLblExpr lbl))
-	; sp_rel <- getSpRelOffset args_sp
-	; stmtC (CmmStore sp_rel (CmmLit (CmmLabel mkSeqInfoLabel))) }
-
 pushReturnAddress _ = nopC
 
 -- -----------------------------------------------------------------------------