X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTailCall.lhs;h=89c050406f746f34fc105aca66d894fc3ac3fc67;hp=dd7327b745f1d6ad41fb89414b049da1cb25c301;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index dd7327b..89c0504 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -1,22 +1,17 @@ % +% (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, + tailCallPrimCall, pushReturnAddress ) where @@ -24,31 +19,26 @@ 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 StaticFlags -import Monad ( when ) +import Control.Monad ----------------------------------------------------------------------------- -- Tail Calls @@ -114,33 +104,41 @@ performTailCall fun_info arg_amodes pending_assts | otherwise = do { fun_amode <- idInfoToAmode fun_info - ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode) + ; let assignSt = CmmAssign nodeReg fun_amode + node_asst = oneStmt assignSt opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; hmods <- getHomeModules - ; case (getCallMethod hmods fun_name lf_info (length arg_amodes)) of + ; dflags <- getDynFlags + ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) - ; doFinalJump sp False (stmtC (CmmJump target [])) } + ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + enterClosure = stmtC (CmmJump target []) + -- If this is a scrutinee + -- let's check if the closure is a constructor + -- so we can directly jump to the alternatives switch + -- statement. + jumpInstr = getEndOfBlockInfo >>= + maybeSwitchOnCons enterClosure + ; doFinalJump sp False jumpInstr } -- A function, but we have zero arguments. It is already in WHNF, -- so we can just return it. -- 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 + ReturnCon _ -> 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) @@ -161,6 +159,7 @@ performTailCall fun_info arg_amodes pending_assts ; directCall sp apply_lbl args extra_args (node_asst `plusStmts` pending_assts) + } -- A direct function call (possibly with some left-over arguments) @@ -179,11 +178,67 @@ performTailCall fun_info arg_amodes pending_assts } } where - fun_name = idName (cgIdInfoId fun_info) + fun_id = cgIdInfoId fun_info + fun_name = idName fun_id lf_info = cgIdInfoLF fun_info - - - + fun_has_cafs = idCafInfo fun_id + untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) + -- Test if closure is a constructor + maybeSwitchOnCons enterClosure eob + | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, + not opt_SccProfilingOn + -- we can't shortcut when profiling is on, because we have + -- to enter a closure to mark it as "used" for LDV profiling + = do { is_constr <- newLabelC + -- Is the pointer tagged? + -- Yes, jump to switch statement + ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) + is_constr) + -- No, enter the closure. + ; enterClosure + ; labelC is_constr + ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) []) + } +{- + -- This is a scrutinee for a case expression + -- so let's see if we can directly inspect the closure + | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob + = do { no_cons <- newLabelC + -- Both the NCG and gcc optimize away the temp + ; z <- newTemp wordRep + ; stmtC (CmmAssign z tag_expr) + ; let tag = CmmReg z + -- Is the closure a cons? + ; stmtC (CmmCondBranch (cond1 tag) no_cons) + ; stmtC (CmmCondBranch (cond2 tag) no_cons) + -- Yes, jump to switch statement + ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) + ; labelC no_cons + -- No, enter the closure. + ; enterClosure + } +-} + -- No case expression involved, enter the closure. + | otherwise + = do { stmtC untag_node + ; enterClosure + } + where + --cond1 tag = cmmULtWord tag lowCons + -- More efficient than the above? +{- + tag_expr = cmmGetClosureType (CmmReg nodeReg) + cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0)) + cond2 tag = cmmUGtWord tag highCons + lowCons = CmmLit (mkIntCLit 1) + -- CONSTR + highCons = CmmLit (mkIntCLit 8) + -- CONSTR_NOCAF_STATIC (from ClosureType.h) +-} + +directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] + -> [(CgRep, CmmExpr)] -> CmmStmts + -> Code directCall sp lbl args extra_args assts = do let -- First chunk of args go in registers @@ -227,17 +282,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 + = 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 +301,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 @@ -290,11 +321,11 @@ emitAlgReturnCode tycon tag returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code returnUnboxedTuple amodes - = do { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo + = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo ; 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 @@ -352,13 +383,21 @@ ccallReturnUnboxedTuple amodes before_jump -- Calling an out-of-line primop tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op args +tailCallPrimOp op + = tailCallPrim (mkRtsPrimOpLabel op) + +tailCallPrimCall :: PrimCall -> [StgArg] -> Code +tailCallPrimCall primcall + = tailCallPrim (mkPrimCallLabel primcall) + +tailCallPrim :: CLabel -> [StgArg] -> Code +tailCallPrim lbl args = do { -- We're going to perform a normal-looking tail call, -- except that *all* the arguments will be in registers. -- Hence the ASSERT( null leftovers ) arg_amodes <- getArgAmodes args ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes - jump_to_primop = jumpToLbl (mkRtsPrimOpLabel op) + jump_to_primop = jumpToLbl lbl ; ASSERT(null leftovers) -- no stack-resident args emitSimultaneously (assignToRegs arg_regs) @@ -384,19 +423,10 @@ tailCallPrimOp op args pushReturnAddress :: EndOfBlockInfo -> Code -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False)) +pushReturnAddress (EndOfBlockInfo args_sp (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 -- ----------------------------------------------------------------------------- @@ -453,3 +483,4 @@ adjustSpAndHp newRealSp ; setRealHp vHp } \end{code} +