diff options
Diffstat (limited to 'compiler/codeGen/CgTailCall.lhs')
| -rw-r--r-- | compiler/codeGen/CgTailCall.lhs | 509 |
1 files changed, 0 insertions, 509 deletions
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs deleted file mode 100644 index b78415fffa..0000000000 --- a/compiler/codeGen/CgTailCall.lhs +++ /dev/null @@ -1,509 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -% Code generation for tail calls. - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module CgTailCall ( - cgTailCall, performTailCall, - performReturn, performPrimReturn, - returnUnboxedTuple, ccallReturnUnboxedTuple, - pushUnboxedTuple, - tailCallPrimOp, - tailCallPrimCall, - - pushReturnAddress - ) where - -#include "HsVersions.h" - -import CgMonad -import CgBindery -import CgInfoTbls -import CgCallConv -import CgStackery -import CgHeapery -import CgUtils -import CgTicky -import ClosureInfo -import OldCmm -import OldCmmUtils -import CLabel -import Type -import Id -import StgSyn -import PrimOp -import DynFlags -import Outputable -import Util - -import Control.Monad -import Data.Maybe - ------------------------------------------------------------------------------ --- Tail Calls - -cgTailCall :: Id -> [StgArg] -> Code - --- Here's the code we generate for a tail call. (NB there may be no --- arguments, in which case this boils down to just entering a variable.) --- --- * Put args in the top locations of the stack. --- * Adjust the stack ptr --- * Make R1 point to the function closure if necessary. --- * Perform the call. --- --- Things to be careful about: --- --- * Don't overwrite stack locations before you have finished with --- them (remember you need the function and the as-yet-unmoved --- arguments). --- * Preferably, generate no code to replace x by x on the stack (a --- common situation in tail-recursion). --- * Adjust the stack high water mark appropriately. --- --- Treat unboxed locals exactly like literals (above) except use the addr --- mode for the local instead of (CLit lit) in the assignment. - -cgTailCall fun args - = do { fun_info <- getCgIdInfo fun - - ; if isUnLiftedType (idType fun) - then -- Primitive return - ASSERT( null args ) - do { fun_amode <- idInfoToAmode fun_info - ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } - - else -- Normal case, fun is boxed - do { arg_amodes <- getArgAmodes args - ; performTailCall fun_info arg_amodes noStmts } - } - - --- ----------------------------------------------------------------------------- --- The guts of a tail-call - -performTailCall - :: CgIdInfo -- The function - -> [(CgRep,CmmExpr)] -- Args - -> CmmStmts -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack assignments. - -> Code - -performTailCall fun_info arg_amodes pending_assts - | Just join_sp <- maybeLetNoEscape fun_info - = -- A let-no-escape is slightly different, because we - -- arrange the stack arguments into pointers and non-pointers - -- to make the heap check easier. The tail-call sequence - -- is very similar to returning an unboxed tuple, so we - -- share some code. - do { dflags <- getDynFlags - ; (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes - ; emitSimultaneously (pending_assts `plusStmts` arg_assts) - ; let lbl = enterReturnPtLabel dflags (idUnique (cgIdInfoId fun_info)) - ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) } - - | otherwise - = do { fun_amode <- idInfoToAmode fun_info - ; dflags <- getDynFlags - ; let assignSt = CmmAssign nodeReg fun_amode - node_asst = oneStmt assignSt - node_live = Just [node] - (opt_node_asst, opt_node_live) - | nodeMustPointToIt dflags lf_info = (node_asst, node_live) - | otherwise = (noStmts, Just []) - ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - - ; 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 dflags (closureInfoPtr dflags (CmmReg nodeReg)) - enterClosure = stmtC (CmmJump target node_live) - -- 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 dflags 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 $ emitReturnInstr node_live } - - -- 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 _ -> do - { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False $ emitReturnInstr node_live } - - JumpToIt lbl -> do - { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) - ; doFinalJump sp False $ jumpToLbl lbl opt_node_live } - - -- A slow function call via the RTS apply routines - -- Node must definitely point to the thing - SlowCall -> do - { when (not (null arg_amodes)) $ do - { if (isKnownFun lf_info) - then tickyKnownCallTooFewArgs - else tickyUnknownCall - ; tickySlowCallPat (map fst arg_amodes) - } - - ; let (apply_lbl, args, extra_args) - = constructSlowCall arg_amodes - - ; directCall sp apply_lbl args extra_args node_live - (node_asst `plusStmts` pending_assts) - - } - - -- A direct function call (possibly with some left-over arguments) - DirectEntry lbl arity -> do - { if arity == length arg_amodes - then tickyKnownCallExact - else do tickyKnownCallExtraArgs - tickySlowCallPat (map fst (drop arity arg_amodes)) - - ; let - -- The args beyond the arity go straight on the stack - (arity_args, extra_args) = splitAt arity arg_amodes - - ; directCall sp lbl arity_args extra_args opt_node_live - (opt_node_asst `plusStmts` pending_assts) - } - } - where - fun_id = cgIdInfoId fun_info - fun_name = idName fun_id - lf_info = cgIdInfoLF fun_info - fun_has_cafs = idCafInfo fun_id - untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)) - -- Test if closure is a constructor - maybeSwitchOnCons dflags enterClosure eob - | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, - not (gopt Opt_SccProfilingOn dflags) - -- 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 dflags (CmmReg nodeReg)) - is_constr) - -- No, enter the closure. - ; enterClosure - ; labelC is_constr - ; stmtC (CmmJump (entryCode dflags $ - CmmLit (CmmLabel lbl)) (Just [node])) - } -{- - -- 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 dflags - ; 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)] -> Maybe [GlobalReg] -> CmmStmts - -> Code -directCall sp lbl args extra_args live_node assts = do - dflags <- getDynFlags - let - -- First chunk of args go in registers - (reg_arg_amodes, stk_args) = assignCallRegs dflags args - - -- Any "extra" arguments are placed in frames on the - -- stack after the other arguments. - slow_stk_args = slowArgs dflags extra_args - - reg_assts = assignToRegs reg_arg_amodes - live_args = map snd reg_arg_amodes - live_regs = Just $ (fromMaybe [] live_node) ++ live_args - -- - (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args) - emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts - doFinalJump final_sp False $ jumpToLbl lbl live_regs - --- ----------------------------------------------------------------------------- --- The final clean-up before we do a jump at the end of a basic block. --- This code is shared by tail-calls and returns. - -doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code -doFinalJump final_sp is_let_no_escape jump_code - = do { -- Adjust the high-water mark if necessary - adjustStackHW final_sp - - -- Push a return address if necessary (after the assignments - -- above, in case we clobber a live stack location) - -- - -- 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. - ; eob <- getEndOfBlockInfo - ; whenC (not is_let_no_escape) (pushReturnAddress eob) - - -- Final adjustment of Sp/Hp - ; adjustSpAndHp final_sp - - -- 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 - -> Code - -performReturn finish_code - = do { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo - ; doFinalJump args_sp False finish_code } - --- ---------------------------------------------------------------------------- --- Primitive Returns --- Just load the return value into the right register, and return. - -performPrimReturn :: CgRep -> CmmExpr -> Code - --- non-void return value -performPrimReturn rep amode | not (isVoidArg rep) - = do { stmtC (CmmAssign ret_reg amode) - ; performReturn $ emitReturnInstr live_regs } - where - -- careful here as 'dataReturnConvPrim' will panic if given a Void rep - ret_reg@(CmmGlobal r) = dataReturnConvPrim rep - live_regs = Just [r] - --- void return value -performPrimReturn _ _ - = performReturn $ emitReturnInstr (Just []) - - --- --------------------------------------------------------------------------- --- Unboxed tuple returns - --- These are a bit like a normal tail call, except that: --- --- - The tail-call target is an info table on the stack --- --- - We separate stack arguments into pointers and non-pointers, --- to make it easier to leave things in a sane state for a heap check. --- This is OK because we can never partially-apply an unboxed tuple, --- unlike a function. The same technique is used when calling --- let-no-escape functions, because they also can't be partially --- applied. - -returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -returnUnboxedTuple amodes - = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo - ; tickyUnboxedTupleReturn (length amodes) - ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes - ; emitSimultaneously assts - ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) } - -pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing - -> [(CgRep, CmmExpr)] -- amodes of the components - -> FCode (VirtualSpOffset, -- final Sp - CmmStmts, -- assignments (regs+stack) - [GlobalReg]) -- registers used (liveness) - -pushUnboxedTuple sp [] - = return (sp, noStmts, []) -pushUnboxedTuple sp amodes - = do { dflags <- getDynFlags - ; let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes - live_regs = map snd reg_arg_amodes - - -- separate the rest of the args into pointers and non-pointers - (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes - reg_arg_assts = assignToRegs reg_arg_amodes - - -- push ptrs, then nonptrs, on the stack - ; (ptr_sp, ptr_assts) <- mkStkAmodes sp ptr_args - ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args - - ; returnFC (final_sp, - reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts, - live_regs) } - - --- ----------------------------------------------------------------------------- --- Returning unboxed tuples. This is mainly to support _ccall_GC_, where --- we want to do things in a slightly different order to normal: --- --- - push return address --- - adjust stack pointer --- - r = call(args...) --- - assign regs for unboxed tuple (usually just R1 = r) --- - return to continuation --- --- The return address (i.e. stack frame) must be on the stack before --- doing the call in case the call ends up in the garbage collector. --- --- Sadly, the information about the continuation is lost after we push it --- (in order to avoid pushing it again), so we end up doing a needless --- indirect jump (ToDo). - -ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code -ccallReturnUnboxedTuple amodes before_jump - = do { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo - - -- Push a return address if necessary - ; pushReturnAddress eob - ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack) - (do { adjustSpAndHp args_sp - ; before_jump - ; returnUnboxedTuple amodes }) - } - --- ----------------------------------------------------------------------------- --- Calling an out-of-line primop - -tailCallPrimOp :: PrimOp -> [StgArg] -> Code -tailCallPrimOp op - = tailCallPrim (mkRtsPrimOpLabel op) - -tailCallPrimCall :: PrimCall -> [StgArg] -> Code -tailCallPrimCall primcall - = tailCallPrim (mkPrimCallLabel primcall) - -tailCallPrim :: CLabel -> [StgArg] -> Code -tailCallPrim lbl args - = do { dflags <- getDynFlags - -- 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 dflags arg_amodes - live_regs = Just $ map snd arg_regs - jump_to_primop = jumpToLbl lbl live_regs - - ; ASSERT(null leftovers) -- no stack-resident args - emitSimultaneously (assignToRegs arg_regs) - - ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo - ; doFinalJump args_sp False jump_to_primop } - --- ----------------------------------------------------------------------------- --- Return Addresses - --- We always push the return address just before performing a tail call --- or return. The reason we leave it until then is because the stack --- slot that the return address is to go into might contain something --- useful. --- --- If the end of block info is 'CaseAlts', then we're in the scrutinee of a --- case expression and the return address is still to be pushed. --- --- There are cases where it doesn't look necessary to push the return --- address: for example, just before doing a return to a known --- continuation. However, the continuation will expect to find the --- return address on the stack in case it needs to do a heap check. - -pushReturnAddress :: EndOfBlockInfo -> Code - -pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _)) - = do { sp_rel <- getSpRelOffset args_sp - ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) } - -pushReturnAddress _ = nopC - --- ----------------------------------------------------------------------------- --- Misc. - --- Passes no argument to the destination procedure -jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code -jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live - -assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts -assignToRegs reg_args - = mkStmts [ CmmAssign (CmmGlobal reg_id) expr - | (expr, reg_id) <- reg_args ] -\end{code} - - -%************************************************************************ -%* * -\subsection[CgStackery-adjust]{Adjusting the stack pointers} -%* * -%************************************************************************ - -This function adjusts the stack and heap pointers just before a tail -call or return. The stack pointer is adjusted to its final position -(i.e. to point to the last argument for a tail call, or the activation -record for a return). The heap pointer may be moved backwards, in -cases where we overallocated at the beginning of the basic block (see -CgCase.lhs for discussion). - -These functions {\em do not} deal with high-water-mark adjustment. -That's done by functions which allocate stack space. - -\begin{code} -adjustSpAndHp :: VirtualSpOffset -- New offset for Arg stack ptr - -> Code -adjustSpAndHp newRealSp - = do { -- Adjust stack, if necessary. - -- NB: the conditional on the monad-carried realSp - -- is out of line (via codeOnly), to avoid a black hole - ; new_sp <- getSpRelOffset newRealSp - ; checkedAbsC (CmmAssign spReg new_sp) -- Will generate no code in the case - ; setRealSp newRealSp -- where realSp==newRealSp - - -- Adjust heap. The virtual heap pointer may be less than the real Hp - -- because the latter was advanced to deal with the worst-case branch - -- of the code, and we may be in a better-case branch. In that case, - -- move the real Hp *back* and retract some ticky allocation count. - ; hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - ; new_hp <- getHpRelOffset vHp - ; checkedAbsC (CmmAssign hpReg new_hp) -- Generates nothing when vHp==rHp - ; tickyAllocHeap (vHp - rHp) -- ...ditto - ; setRealHp vHp - } -\end{code} - |