X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=9d5118a77da50e67d272da3d010ead4c360ed457;hb=cd0f89a0bf35c36575ea89d7c7599473a3600683;hp=95055d854ea8274c6cbe104de60a2e2534b01709;hpb=9d4c03805bafb6b1e1d47306b6a6c591c998e517;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 95055d8..9d5118a 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,5 +1,7 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +% $Id: CgTailCall.lhs,v 1.38 2003/06/02 13:27:34 simonpj Exp $ % %******************************************************** %* * @@ -8,165 +10,324 @@ %******************************************************** \begin{code} -#include "HsVersions.h" - module CgTailCall ( - cgTailCall, - performReturn, + cgTailCall, performTailCall, + performReturn, performPrimReturn, mkStaticAlgReturnCode, mkDynamicAlgReturnCode, + returnUnboxedTuple, ccallReturnUnboxedTuple, mkPrimReturnCode, + tailCallPrimOp, - tailCallBusiness + pushReturnAddress ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" import CgMonad +import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) +import CgRetConv +import CgStackery +import CgUsages ( getSpRelOffset, adjustSpAndHp ) +import ClosureInfo + +import AbsCUtils ( mkAbstractCs, getAmodeRep ) import AbsCSyn +import CLabel ( mkRtsPrimOpLabel, mkSeqInfoLabel ) -import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) -import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) -import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg, - ctrlReturnConvAlg, CtrlReturnConvention(..), - DataReturnConvention(..) - ) -import CgStackery ( adjustRealSps, mkStkAmodes ) -import CgUsages ( getSpARelOffset ) -import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) -import ClosureInfo ( nodeMustPointToIt, - getEntryConvention, EntryConvention(..), - LambdaFormInfo - ) -import CmdLineOpts ( opt_DoSemiTagging ) -import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) ) -import Id ( idType, dataConTyCon, dataConTag, - fIRST_TAG - ) -import Literal ( mkMachInt ) -import Maybes ( assocMaybe ) +import Id ( Id, idType, idName ) +import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) import PrimRep ( PrimRep(..) ) -import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) ) -import Type ( isPrimType ) -import Util ( zipWithEqual, panic, assertPanic ) -\end{code} +import StgSyn ( StgArg ) +import Type ( isUnLiftedType ) +import Name ( Name ) +import TyCon ( TyCon ) +import PrimOp ( PrimOp ) +import Util ( zipWithEqual, splitAtList ) +import ListSetOps ( assocMaybe ) +import PrimRep ( isFollowableRep ) +import Outputable +import Panic ( panic, assertPanic ) + +import List ( partition ) + +----------------------------------------------------------------------------- +-- 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. + +-- Case for unboxed returns first: +cgTailCall fun [] + | isUnLiftedType (idType fun) + = getCAddrMode fun `thenFC` \ amode -> + performPrimReturn (ppr fun) amode + +-- The general case (@fun@ is boxed): +cgTailCall fun args + = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) -> + getArgAmodes args `thenFC` \ arg_amodes -> + performTailCall fun' fun_amode lf_info arg_amodes AbsCNop + + +-- ----------------------------------------------------------------------------- +-- The guts of a tail-call + +performTailCall + :: Id -- function + -> CAddrMode -- function amode + -> LambdaFormInfo + -> [CAddrMode] + -> AbstractC -- Pending simultaneous assignments + -- *** GUARANTEED to contain only stack assignments. + -> Code + +performTailCall fun fun_amode lf_info arg_amodes pending_assts = + nodeMustPointToIt lf_info `thenFC` \ node_points -> + let + -- assign to node if necessary + node_asst + | node_points = CAssign (CReg node) fun_amode + | otherwise = AbsCNop + in + + getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> -%************************************************************************ -%* * -\subsection[tailcall-doc]{Documentation} -%* * -%************************************************************************ + let + -- set up for a let-no-escape if necessary + join_sp = case fun_amode of + CJoinPoint sp -> sp + other -> args_sp + in -\begin{code} -cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code -\end{code} + -- decide how to code the tail-call: which registers assignments to make, + -- what args to push on the stack, and how to make the jump + constructTailCall (idName fun) lf_info arg_amodes join_sp + node_points fun_amode sequel + `thenFC` \ (final_sp, arg_assts, jump_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.) - -\begin{itemize} -\item Adjust the stack ptr to \tr{tailSp + #args}. -\item Put args in the top locations of the resulting stack. -\item Make Node point to the function closure. -\item Enter the function closure. -\end{itemize} - -Things to be careful about: -\begin{itemize} -\item Don't overwrite stack locations before you have finished with - them (remember you need the function and the as-yet-unmoved - arguments). -\item Preferably, generate no code to replace x by x on the stack (a - common situation in tail-recursion). -\item Adjust the stack high water mark appropriately. -\end{itemize} - -Literals are similar to constructors; they return by putting -themselves in an appropriate register and returning to the address on -top of the B stack. + let sim_assts = mkAbstractCs [node_asst, + pending_assts, + arg_assts] -\begin{code} -cgTailCall (StgLitArg lit) [] live_vars - = performPrimReturn (CLit lit) live_vars -\end{code} + is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False } + in -Treat unboxed locals exactly like literals (above) except use the addr -mode for the local instead of (CLit lit) in the assignment. + doFinalJump final_sp sim_assts is_lne (const jump_code) + + +-- Figure out how to do a particular tail-call. + +constructTailCall + :: Name + -> LambdaFormInfo + -> [CAddrMode] + -> VirtualSpOffset -- Sp at which to make the call + -> Bool -- node points to the fun closure? + -> CAddrMode -- addressing mode of the function + -> Sequel -- the sequel, in case we need it + -> FCode ( + VirtualSpOffset, -- Sp after pushing the args + AbstractC, -- assignments + Code -- code to do the jump + ) + +constructTailCall name lf_info arg_amodes sp node_points fun_amode sequel = + + getEntryConvention name lf_info (map getAmodeRep arg_amodes) + `thenFC` \ entry_conv -> + + case entry_conv of + EnterIt -> returnFC (sp, AbsCNop, code) + where code = profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC` + absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE + [CVal (nodeRel 0) DataPtrRep])) + + -- A function, but we have zero arguments. It is already in WHNF, + -- so we can just return it. + ReturnIt -> returnFC (sp, asst, code) + where -- if node doesn't already point to the closure, we have to + -- load it up. + asst | node_points = AbsCNop + | otherwise = CAssign (CReg node) fun_amode + + code = sequelToAmode sequel `thenFC` \ dest_amode -> + absC (CReturn dest_amode DirectReturn) + + JumpToIt lbl -> returnFC (sp, AbsCNop, code) + where code = absC (CJump (CLbl lbl CodePtrRep)) + + -- a slow function call via the RTS apply routines + SlowCall -> + let (apply_fn, new_amodes) = constructSlowCall arg_amodes + + -- if node doesn't already point to the closure, + -- we have to load it up. + node_asst | node_points = AbsCNop + | otherwise = CAssign (CReg node) fun_amode + in -Case for unboxed @Ids@ first: -\begin{code} -cgTailCall atom@(StgVarArg fun) [] live_vars - | isPrimType (idType fun) - = getCAddrMode fun `thenFC` \ amode -> - performPrimReturn amode live_vars -\end{code} + -- Fill in all the arguments on the stack + mkStkAmodes sp new_amodes `thenFC` + \ (final_sp, stk_assts) -> + + returnFC + (final_sp + 1, -- add one, because the stg_ap functions + -- expect there to be a free slot on the stk + mkAbstractCs [node_asst, stk_assts], + absC (CJump apply_fn) + ) + + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity regs + + -- 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. + | is_let_no_escape -> + pushUnboxedTuple sp arg_amodes `thenFC` \ (final_sp, assts) -> + returnFC (final_sp, assts, absC (CJump (CLbl lbl CodePtrRep))) + + + -- A normal fast call + | otherwise -> + let + -- first chunk of args go in registers + (reg_arg_amodes, stk_arg_amodes) = + splitAtList regs arg_amodes + + -- the rest of this function's args go straight on the stack + (stk_args, extra_stk_args) = + splitAt (arity - length regs) stk_arg_amodes + + -- any "extra" arguments are placed in frames on the + -- stack after the other arguments. + slow_stk_args = slowArgs extra_stk_args + + reg_assts + = mkAbstractCs (zipWithEqual "assign_to_reg2" + assign_to_reg regs reg_arg_amodes) -The general case (@fun@ is boxed): -\begin{code} -cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars -\end{code} + in + mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC` + \ (final_sp, stk_assts) -> -%************************************************************************ -%* * -\subsection[return-and-tail-call]{Return and tail call} -%* * -%************************************************************************ + returnFC + (final_sp, + mkAbstractCs [reg_assts, stk_assts], + absC (CJump (CLbl lbl CodePtrRep)) + ) -ADR-HACK + where is_let_no_escape = case fun_amode of + CJoinPoint _ -> True + _ -> False - A quick bit of hacking to try to solve my void#-leaking blues... +-- ----------------------------------------------------------------------------- +-- 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. - I think I'm getting bitten by this stuff because code like +doFinalJump :: VirtualSpOffset -> AbstractC -> Bool -> (Sequel -> Code) -> Code +doFinalJump final_sp sim_assts is_let_no_escape jump_code = - \begin{pseudocode} - case ds.s12 :: IoWorld of { - -- lvs: [ds.s12]; rhs lvs: []; uniq: c0 - IoWorld ds.s13# -> ds.s13#; - } :: Universe# - \end{pseudocode} + -- adjust the high-water mark if necessary + adjustStackHW final_sp `thenC` - causes me to try to allocate a register to return the result in. The - hope is that the following will avoid such problems (and that Will - will do this in a cleaner way when he hits the same problem). + -- Do the simultaneous assignments, + absC (CSimultaneous sim_assts) `thenC` -KCAH-RDA + -- 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. + getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> + (if is_let_no_escape then nopC + else pushReturnAddress eob) `thenC` -\begin{code} -performPrimReturn :: CAddrMode -- The thing to return - -> StgLiveVars + -- Final adjustment of Sp/Hp + adjustSpAndHp final_sp `thenC` + + -- and do the jump + jump_code sequel + +-- ----------------------------------------------------------------------------- +-- A general return (just a special case of doFinalJump, above) + +performReturn :: AbstractC -- Simultaneous assignments to perform + -> (Sequel -> Code) -- The code to execute to actually do + -- the return, given an addressing mode + -- for the return address + -> Code + +performReturn sim_assts finish_code + = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> + doFinalJump args_sp sim_assts False{-not a LNE-} finish_code + +-- ----------------------------------------------------------------------------- +-- Primitive Returns + +-- Just load the return value into the right register, and return. + +performPrimReturn :: SDoc -- Just for debugging (sigh) + -> CAddrMode -- The thing to return -> Code -performPrimReturn amode live_vars +performPrimReturn doc amode = let kind = getAmodeRep amode ret_reg = dataReturnConvPrim kind assign_possibly = case kind of - VoidRep -> AbsCNop - kind -> (CAssign (CReg ret_reg) amode) + VoidRep -> AbsCNop + kind -> (CAssign (CReg ret_reg) amode) in - performReturn assign_possibly mkPrimReturnCode live_vars + performReturn assign_possibly (mkPrimReturnCode doc) -mkPrimReturnCode :: Sequel -> Code -mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd" -mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode -> +mkPrimReturnCode :: SDoc -- Debugging only + -> Sequel + -> Code +mkPrimReturnCode doc UpdateCode = pprPanic "mkPrimReturnCode: Upd" doc +mkPrimReturnCode doc sequel = sequelToAmode sequel `thenFC` \ dest_amode -> absC (CReturn dest_amode DirectReturn) -- Direct, no vectoring --- All constructor arguments in registers; Node and InfoPtr are set. +-- ----------------------------------------------------------------------------- +-- Algebraic constructor returns + +-- Constructor is built on the heap; Node is set. -- All that remains is -- (a) to set TagReg, if necessary --- (b) to set InfoPtr to the info ptr, if necessary -- (c) to do the right sort of jump. -mkStaticAlgReturnCode :: Id -- The constructor - -> Maybe CLabel -- The info ptr, if it isn't already set +mkStaticAlgReturnCode :: DataCon -- The constructor -> Sequel -- where to return to -> Code -mkStaticAlgReturnCode con maybe_info_lbl sequel +mkStaticAlgReturnCode con sequel = -- Generate profiling code if necessary (case return_convention of - VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] + VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] other -> nopC ) `thenC` @@ -185,31 +346,19 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel -- Generate the right jump or return (case sequel of - UpdateCode _ -> -- Ha! We know the constructor, - -- so we can go direct to the correct - -- update code for that constructor - - -- Set the info pointer, and jump - set_info_ptr `thenC` - absC (CJump (CLbl update_label CodePtrRep)) - - CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so + CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so -- we can go right to the alternative - -- No need to set info ptr when returning to a - -- known join point. After all, the code at - -- the destination knows what constructor it - -- is going to handle. - - case assocMaybe alts tag of - Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrRep)) - Nothing -> panic "mkStaticAlgReturnCode: default" - -- The Nothing case should never happen; it's the subject - -- of a wad of special-case code in cgReturnCon + case assocMaybe alts tag of + Just (alt_absC, join_lbl) -> + absC (CJump (CLbl join_lbl CodePtrRep)) + Nothing -> panic "mkStaticAlgReturnCode: default" + -- The Nothing case should never happen; + -- it's the subject of a wad of special-case + -- code in cgReturnCon - other -> -- OnStack, or (CaseAlts) ret_amode Nothing) - -- Set the info pointer, and jump - set_info_ptr `thenC` + other -> -- OnStack, or (CaseAlts ret_amode Nothing), + -- or UpdateCode. sequelToAmode sequel `thenFC` \ ret_amode -> absC (CReturn ret_amode return_info) ) @@ -221,19 +370,17 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed -- cf AbsCUtils.mkAlgAltsCSwitch - update_label - = case (dataReturnConvAlg con) of - ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag - ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag + return_info = + case return_convention of + UnvectoredReturn _ -> DirectReturn + VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag - return_info = case return_convention of - UnvectoredReturn _ -> DirectReturn - VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag - set_info_ptr = case maybe_info_lbl of - Nothing -> nopC - Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep)) +-- ----------------------------------------------------------------------------- +-- Returning an enumerated type from a PrimOp +-- This function is used by PrimOps that return enumerated types (i.e. +-- all the comparison operators). mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code @@ -241,7 +388,7 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel = case ctrlReturnConvAlg tycon of VectoredReturn sz -> - profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC` + profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC` sequelToAmode sequel `thenFC` \ ret_addr -> absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) @@ -261,268 +408,166 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel sequelToAmode sequel `thenFC` \ ret_addr -> -- Generate the right jump or return absC (CReturn ret_addr DirectReturn) -\end{code} - -\begin{code} -performReturn :: AbstractC -- Simultaneous assignments to perform - -> (Sequel -> Code) -- The code to execute to actually do - -- the return, given an addressing mode - -- for the return address - -> StgLiveVars - -> Code -performReturn sim_assts finish_code live_vars - = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> - -- Do the simultaneous assignments, - doSimAssts args_spa live_vars sim_assts `thenC` +-- --------------------------------------------------------------------------- +-- Unboxed tuple returns - -- Adjust stack pointers - adjustRealSps args_spa args_spb `thenC` +-- 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. - -- Do the return - finish_code sequel -- "sequel" is `robust' in that it doesn't - -- depend on stk-ptr values -\end{code} - -\begin{code} -performTailCall :: Id -- Function - -> [StgArg] -- Args - -> StgLiveVars - -> Code - -performTailCall fun args live_vars - = -- Get all the info we have about the function and args and go on to - -- the business end - getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) -> - getArgAmodes args `thenFC` \ arg_amodes -> - - tailCallBusiness - fun fun_amode lf_info arg_amodes - live_vars AbsCNop {- No pending assignments -} +returnUnboxedTuple :: [CAddrMode] -> Code +returnUnboxedTuple amodes = + getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> + profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` -tailCallBusiness :: Id -> CAddrMode -- Function and its amode - -> LambdaFormInfo -- Info about the function - -> [CAddrMode] -- Arguments - -> StgLiveVars -- Live in continuation + pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) -> + doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode - -> AbstractC -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack assignments. - -- In ptic, we don't need to look in here to - -- discover all live regs - -> Code +pushUnboxedTuple + :: VirtualSpOffset -- Sp at which to start pushing + -> [CAddrMode] -- amodes of the components + -> FCode (VirtualSpOffset, -- final Sp + AbstractC) -- assignments (regs+stack) -tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts - = nodeMustPointToIt lf_info `thenFC` \ node_points -> - getEntryConvention fun lf_info - (map getAmodeRep arg_amodes) `thenFC` \ entry_conv -> +pushUnboxedTuple sp amodes = + let + (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes) - getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> + (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes - let - node_asst - = if node_points then - CAssign (CReg node) fun_amode - else - AbsCNop - - (arg_regs, finish_code) - = case entry_conv of - ViaNode -> - ([], - mkAbstractCs [ - CCallProfCtrMacro SLIT("ENT_VIA_NODE") [], - CAssign (CReg infoptr) - - (CMacroExpr DataPtrRep INFO_PTR [CReg node]), - CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) - ]) - StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep)) - StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep) - `mkAbsCStmts` - CJump (CLbl lbl CodePtrRep)) - DirectEntry lbl arity regs -> - (regs, CJump (CLbl lbl CodePtrRep)) - - no_of_args = length arg_amodes - - (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes - -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity + -- separate the rest of the args into pointers and non-pointers + ( ptr_args, nptr_args ) = + partition (isFollowableRep . getAmodeRep) stk_arg_amodes reg_arg_assts - = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes) - - assign_to_reg reg_id amode = CAssign (CReg reg_id) amode + = mkAbstractCs (zipWithEqual "assign_to_reg2" + assign_to_reg arg_regs reg_arg_amodes) in - case fun_amode of - CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy - ASSERT(not (args_spa > join_spa) || (args_spb > join_spb)) - -- If ASSERTion fails: Oops: the join point has *lower* - -- stack ptrs than the continuation Note that we take - -- the SpB point without the return address here. The - -- return address is put on by the let-no-escapey thing - -- when it finishes. + -- push ptrs, then nonptrs, on the stack + mkStkAmodes sp ptr_args `thenFC` \ (ptr_sp, ptr_assts) -> + mkStkAmodes ptr_sp nptr_args `thenFC` \ (final_sp, nptr_assts) -> - mkStkAmodes join_spa join_spb stk_arg_amodes - `thenFC` \ (final_spa, final_spb, stk_arg_assts) -> + returnFC (final_sp, + mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts]) + + - -- Do the simultaneous assignments, - doSimAssts join_spa live_vars - (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts]) - `thenC` +mkUnboxedTupleReturnCode :: Sequel -> Code +mkUnboxedTupleReturnCode sequel + = case sequel of + -- can't update with an unboxed tuple! + UpdateCode -> panic "mkUnboxedTupleReturnCode" - -- Adjust stack ptrs - adjustRealSps final_spa final_spb `thenC` + CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False -> + absC (CJump (CLbl join_lbl CodePtrRep)) - -- Jump to join point - absC finish_code - - _ -> -- else: not a let-no-escape (the common case) - - -- Make instruction to save return address - loadRetAddrIntoRetReg sequel `thenFC` \ ret_asst -> - - mkStkAmodes args_spa args_spb stk_arg_amodes - `thenFC` - \ (final_spa, final_spb, stk_arg_assts) -> - - -- The B-stack space for the pushed return addess, with any args pushed - -- on top, is recorded in final_spb. + other -> -- OnStack, or (CaseAlts ret_amode something) + sequelToAmode sequel `thenFC` \ ret_amode -> + absC (CReturn ret_amode DirectReturn) + +-- ----------------------------------------------------------------------------- +-- 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 :: [CAddrMode] -> Code -> Code +ccallReturnUnboxedTuple amodes before_jump + = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> + + -- push a return address if necessary + pushReturnAddress eob `thenC` + setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) ( + + -- Adjust Sp/Hp + adjustSpAndHp args_sp `thenC` + + before_jump `thenC` + + returnUnboxedTuple amodes + ) + +-- ----------------------------------------------------------------------------- +-- Calling an out-of-line primop + +tailCallPrimOp :: PrimOp -> [StgArg] -> Code +tailCallPrimOp op args = + -- we're going to perform a normal-looking tail call, + -- except that *all* the arguments will be in registers. + getArgAmodes args `thenFC` \ arg_amodes -> + let (arg_regs, leftovers) = assignAllRegs [] (map getAmodeRep arg_amodes) - -- Do the simultaneous assignments, - doSimAssts args_spa live_vars - (mkAbstractCs [pending_assts, node_asst, ret_asst, - reg_arg_assts, stk_arg_assts]) - `thenC` + reg_arg_assts + = mkAbstractCs (zipWithEqual "assign_to_reg2" + assign_to_reg arg_regs arg_amodes) - -- Final adjustment of stack pointers - adjustRealSps final_spa final_spb `thenC` + jump_to_primop = + absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep)) + in - -- Now decide about semi-tagging - let - semi_tagging_on = opt_DoSemiTagging - in - case (semi_tagging_on, arg_amodes, node_points, sequel) of + ASSERT(null leftovers) -- no stack-resident args - -- - -- *************** The semi-tagging case *************** - -- - ( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) -> - - -- Whoppee! Semi-tagging rules OK! - -- (a) semi-tagging is switched on - -- (b) there are no arguments, - -- (c) Node points to the closure - -- (d) we have a case-alternative sequel with - -- some visible alternatives - - -- Why is test (c) necessary? - -- Usually Node will point to it at this point, because we're - -- scrutinsing something which is either a thunk or a - -- constructor. - -- But not always! The example I came across is when we have - -- a top-level Double: - -- lit.3 = D# 3.000 - -- ... (case lit.3 of ...) ... - -- Here, lit.3 is built as a re-entrant thing, which you must enter. - -- (OK, the simplifier should have eliminated this, but it's - -- easy to deal with the case anyway.) - let - join_details_to_code (load_regs_and_profiling_code, join_lbl) - = load_regs_and_profiling_code `mkAbsCStmts` - CJump (CLbl join_lbl CodePtrRep) - - semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)), - join_details_to_code join_details) - | (tag, join_details) <- st_alts - ] - - enter_jump - -- Enter Node (we know infoptr will have the info ptr in it)! - = mkAbstractCs [ - CCallProfCtrMacro SLIT("RET_SEMI_FAILED") - [CMacroExpr IntRep INFO_TAG [CReg infoptr]], - CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ] - in - -- Final switch - absC (mkAbstractCs [ - CAssign (CReg infoptr) - (CVal (NodeRel zeroOff) DataPtrRep), - - case maybe_deflt_join_details of - Nothing -> - CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr]) - (semi_tagged_alts) - (enter_jump) - Just (_, details) -> - CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr]) - [(mkMachInt 0, enter_jump)] - (CSwitch - (CMacroExpr IntRep INFO_TAG [CReg infoptr]) - (semi_tagged_alts) - (join_details_to_code details)) - ]) + getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> + doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop) - -- - -- *************** The non-semi-tagging case *************** - -- - other -> absC finish_code -\end{code} +-- ----------------------------------------------------------------------------- +-- Return Addresses -\begin{code} -loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC +-- | 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. -loadRetAddrIntoRetReg InRetReg - = returnFC AbsCNop -- Return address already there +pushReturnAddress :: EndOfBlockInfo -> Code -loadRetAddrIntoRetReg sequel - = sequelToAmode sequel `thenFC` \ amode -> - returnFC (CAssign (CReg RetReg) amode) +pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) = + getSpRelOffset args_sp `thenFC` \ sp_rel -> + absC (CAssign (CVal sp_rel RetRep) amode) -\end{code} +-- 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 amode _ True)) = + getSpRelOffset (args_sp-1) `thenFC` \ sp_rel -> + absC (CAssign (CVal sp_rel RetRep) amode) `thenC` + getSpRelOffset args_sp `thenFC` \ sp_rel -> + absC (CAssign (CVal sp_rel RetRep) (CLbl mkSeqInfoLabel RetRep)) +pushReturnAddress _ = nopC -%************************************************************************ -%* * -\subsection[doSimAssts]{@doSimAssts@} -%* * -%************************************************************************ +-- ----------------------------------------------------------------------------- +-- Misc. -@doSimAssts@ happens at the end of every block of code. -They are separate because we sometimes do some jiggery-pokery in between. +assign_to_reg reg_id amode = CAssign (CReg reg_id) amode -\begin{code} -doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation - -> StgLiveVars -- Live in continuation - -> AbstractC - -> Code - -doSimAssts tail_spa live_vars sim_assts - = -- Do the simultaneous assignments - absC (CSimultaneous sim_assts) `thenC` - - -- Stub any unstubbed slots; the only live variables are indicated in - -- the end-of-block info in the monad - nukeDeadBindings live_vars `thenC` - getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots -> - -- Passing in tail_spa here should actually be redundant, because - -- the stack should be trimmed (by nukeDeadBindings) to - -- exactly the tail_spa position anyhow. - - -- Emit code to stub dead regs; this only generates actual - -- machine instructions in in the DEBUG version - -- *** NOT DONE YET *** - - (if (null a_slots) - then nopC - else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC` - mapCs stub_A_slot a_slots - ) - where - stub_A_slot :: VirtualSpAOffset -> Code - stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel -> - absC (CAssign (CVal spa_rel PtrRep) - (CReg StkStubReg)) \end{code}