X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=982891b2f7993b56d8498cca54c9ef7e8e15e229;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=9d5118a77da50e67d272da3d010ead4c360ed457;hpb=553e90d9a32ee1b1809430f260c401cc4169c6c7;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 9d5118a..982891b 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.38 2003/06/02 13:27:34 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $ % %******************************************************** %* * @@ -13,9 +13,9 @@ module CgTailCall ( cgTailCall, performTailCall, performReturn, performPrimReturn, - mkStaticAlgReturnCode, mkDynamicAlgReturnCode, + emitKnownConReturnCode, emitAlgReturnCode, returnUnboxedTuple, ccallReturnUnboxedTuple, - mkPrimReturnCode, + pushUnboxedTuple, tailCallPrimOp, pushReturnAddress @@ -24,31 +24,31 @@ module CgTailCall ( #include "HsVersions.h" import CgMonad -import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) -import CgRetConv -import CgStackery -import CgUsages ( getSpRelOffset, adjustSpAndHp ) +import CgBindery ( getArgAmodes, getCgIdInfo, CgIdInfo, maybeLetNoEscape, + idInfoToAmode, cgIdInfoId, cgIdInfoLF, + cgIdInfoArgRep ) +import CgInfoTbls ( entryCode, emitDirectReturnInstr, dataConTagZ, + emitVectoredReturnInstr, closureInfoPtr ) +import CgCallConv +import CgStackery ( setRealSp, mkStkAmodes, adjustStackHW, + getSpRelOffset ) +import CgHeapery ( setRealHp, getHpRelOffset ) +import CgUtils ( emitSimultaneously ) +import CgTicky import ClosureInfo - -import AbsCUtils ( mkAbstractCs, getAmodeRep ) -import AbsCSyn -import CLabel ( mkRtsPrimOpLabel, mkSeqInfoLabel ) - -import Id ( Id, idType, idName ) -import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG ) -import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg ) +import SMRep ( CgRep, isVoidArg, separateByPtrFollowness ) +import Cmm +import CmmUtils +import CLabel ( CLabel, mkRtsPrimOpLabel, mkSeqInfoLabel ) import Type ( isUnLiftedType ) -import Name ( Name ) +import Id ( Id, idName, idUnique, idType ) +import DataCon ( DataCon, dataConTyCon ) +import StgSyn ( StgArg ) 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 ) +import Monad ( when ) ----------------------------------------------------------------------------- -- Tail Calls @@ -75,339 +75,205 @@ cgTailCall :: Id -> [StgArg] -> Code -- 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 - + = 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 - :: Id -- function - -> CAddrMode -- function amode - -> LambdaFormInfo - -> [CAddrMode] - -> AbstractC -- Pending simultaneous assignments - -- *** GUARANTEED to contain only stack assignments. + :: CgIdInfo -- The function + -> [(CgRep,CmmExpr)] -- Args + -> CmmStmts -- 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) -> - - let - -- set up for a let-no-escape if necessary - join_sp = case fun_amode of - CJoinPoint sp -> sp - other -> args_sp - in - - -- 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) -> - - let sim_assts = mkAbstractCs [node_asst, - pending_assts, - arg_assts] - - is_lne = case fun_amode of { CJoinPoint _ -> True; _ -> False } - in - - 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 - - -- 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 +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. - | 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) + do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes + ; emitSimultaneously (pending_assts `plusStmts` arg_assts) + ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info)) + ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) } + + | otherwise + = do { fun_amode <- idInfoToAmode fun_info + ; let node_asst = oneStmt (CmmAssign nodeReg fun_amode) + opt_node_asst | nodeMustPointToIt lf_info = node_asst + | otherwise = noStmts + ; EndOfBlockInfo sp _ <- getEndOfBlockInfo + + ; case (getCallMethod fun_name 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 [])) } + + -- 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 } + + -- 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) } + + JumpToIt lbl -> do + { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) + ; doFinalJump sp False (jumpToLbl lbl) } + + -- A slow function call via the RTS apply routines + -- Node must definitely point to the thing + SlowCall -> do + { let (apply_lbl, new_amodes) = constructSlowCall arg_amodes - in - mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC` - \ (final_sp, stk_assts) -> + -- Fill in all the arguments on the stack + ; (final_sp,stk_assts) <- mkStkAmodes sp new_amodes + + ; emitSimultaneously (node_asst `plusStmts` stk_assts + `plusStmts` pending_assts) + + ; when (not (null arg_amodes)) $ do + { if (isKnownFun lf_info) + then tickyKnownCallTooFewArgs + else tickyUnknownCall + ; tickySlowCallPat (map fst arg_amodes) + } + + ; doFinalJump (final_sp + 1) + -- Add one, because the stg_ap functions + -- expect there to be a free slot on the stk + False (jumpToLbl apply_lbl) + } + + -- A direct function call (possibly with some left-over arguments) + DirectEntry lbl arity -> do + { let + -- The args beyond the arity go straight on the stack + (arity_args, extra_stk_args) = splitAt arity arg_amodes + + -- First chunk of args go in registers + (reg_arg_amodes, stk_args) = assignCallRegs arity_args + + -- Any "extra" arguments are placed in frames on the + -- stack after the other arguments. + slow_stk_args = slowArgs extra_stk_args + + reg_assts = assignToRegs reg_arg_amodes + + ; if null slow_stk_args + then tickyKnownCallExact + else do tickyKnownCallExtraArgs + tickySlowCallPat (map fst extra_stk_args) + + ; (final_sp, stk_assts) <- mkStkAmodes sp + (stk_args ++ slow_stk_args) + + ; emitSimultaneously (opt_node_asst `plusStmts` + reg_assts `plusStmts` + stk_assts `plusStmts` + pending_assts) + + ; doFinalJump final_sp False (jumpToLbl lbl) } + } + where + fun_name = idName (cgIdInfoId fun_info) + lf_info = cgIdInfoLF fun_info - returnFC - (final_sp, - mkAbstractCs [reg_assts, stk_assts], - absC (CJump (CLbl lbl CodePtrRep)) - ) - where is_let_no_escape = case fun_amode of - CJoinPoint _ -> True - _ -> False -- ----------------------------------------------------------------------------- -- 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 -> AbstractC -> Bool -> (Sequel -> Code) -> Code -doFinalJump final_sp sim_assts is_let_no_escape jump_code = - - -- adjust the high-water mark if necessary - adjustStackHW final_sp `thenC` +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 - -- Do the simultaneous assignments, - absC (CSimultaneous sim_assts) `thenC` - - -- push a return address if necessary (after the assignments + -- 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` + ; eob <- getEndOfBlockInfo + ; whenC (not is_let_no_escape) (pushReturnAddress eob) - -- Final adjustment of Sp/Hp - adjustSpAndHp final_sp `thenC` + -- Final adjustment of Sp/Hp + ; adjustSpAndHp final_sp - -- and do the jump - jump_code sequel + -- and do the jump + ; jump_code } -- ----------------------------------------------------------------------------- -- 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 +performReturn :: Code -- The code to execute to actually do the return -> Code -performReturn sim_assts finish_code - = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - doFinalJump args_sp sim_assts False{-not a LNE-} finish_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. -performPrimReturn :: SDoc -- Just for debugging (sigh) - -> CAddrMode -- The thing to return +performPrimReturn :: CgRep -> CmmExpr -- The thing to return -> Code - -performPrimReturn doc amode - = let - kind = getAmodeRep amode - ret_reg = dataReturnConvPrim kind - - assign_possibly = case kind of - VoidRep -> AbsCNop - kind -> (CAssign (CReg ret_reg) amode) - in - performReturn assign_possibly (mkPrimReturnCode doc) - -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 +performPrimReturn rep amode + = do { whenC (not (isVoidArg rep)) + (stmtC (CmmAssign ret_reg amode)) + ; performReturn emitDirectReturnInstr } + where + ret_reg = dataReturnConvPrim rep -- ----------------------------------------------------------------------------- -- Algebraic constructor returns -- Constructor is built on the heap; Node is set. --- All that remains is --- (a) to set TagReg, if necessary --- (c) to do the right sort of jump. - -mkStaticAlgReturnCode :: DataCon -- The constructor - -> Sequel -- where to return to - -> Code - -mkStaticAlgReturnCode con sequel - = -- Generate profiling code if necessary - (case return_convention of - VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] - other -> nopC - ) `thenC` - - -- Set tag if necessary - -- This is done by a macro, because if we are short of registers - -- we don't set TagReg; instead the continuation gets the tag - -- by indexing off the info ptr - (case return_convention of - - UnvectoredReturn no_of_constrs - | no_of_constrs > 1 - -> absC (CMacroStmt SET_TAG [mkIntCLit zero_indexed_tag]) - - other -> nopC - ) `thenC` - - -- Generate the right jump or return - (case sequel of - CaseAlts _ (Just (alts, _)) False -> -- Ho! We know the constructor so - -- we can go right to the alternative - - 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), - -- or UpdateCode. - sequelToAmode sequel `thenFC` \ ret_amode -> - absC (CReturn ret_amode return_info) - ) +-- All that remains is to do the right sort of jump. - where - tag = dataConTag con - tycon = dataConTyCon con - return_convention = ctrlReturnConvAlg tycon - zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed - -- cf AbsCUtils.mkAlgAltsCSwitch - - return_info = - case return_convention of - UnvectoredReturn _ -> DirectReturn - VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag - - --- ----------------------------------------------------------------------------- --- Returning an enumerated type from a PrimOp +emitKnownConReturnCode :: DataCon -> Code +emitKnownConReturnCode con + = emitAlgReturnCode (dataConTyCon con) + (CmmLit (mkIntCLit (dataConTagZ con))) + -- emitAlgReturnCode requires zero-indexed tag --- This function is used by PrimOps that return enumerated types (i.e. +emitAlgReturnCode :: TyCon -> CmmExpr -> Code +-- emitAlgReturnCode is used both by emitKnownConReturnCode, +-- and by by PrimOps that return enumerated types (i.e. -- all the comparison operators). - -mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code - -mkDynamicAlgReturnCode tycon dyn_tag sequel - = case ctrlReturnConvAlg tycon of - VectoredReturn sz -> - - profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC` - sequelToAmode sequel `thenFC` \ ret_addr -> - absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) - - UnvectoredReturn no_of_constrs -> - - -- Set tag if necessary - -- This is done by a macro, because if we are short of registers - -- we don't set TagReg; instead the continuation gets the tag - -- by indexing off the info ptr - (if no_of_constrs > 1 then - absC (CMacroStmt SET_TAG [dyn_tag]) - else - nopC - ) `thenC` - - - sequelToAmode sequel `thenFC` \ ret_addr -> - -- Generate the right jump or return - absC (CReturn ret_addr DirectReturn) +emitAlgReturnCode tycon tag + = do { case ctrlReturnConvAlg tycon of + VectoredReturn fam_sz -> do { tickyVectoredReturn fam_sz + ; emitVectoredReturnInstr tag } + UnvectoredReturn _ -> emitDirectReturnInstr + } -- --------------------------------------------------------------------------- @@ -424,59 +290,37 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel -- let-no-escape functions, because they also can't be partially -- applied. -returnUnboxedTuple :: [CAddrMode] -> Code -returnUnboxedTuple amodes = - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - - profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` - - pushUnboxedTuple args_sp amodes `thenFC` \ (final_sp, assts) -> - doFinalJump final_sp assts False{-not a LNE-} mkUnboxedTupleReturnCode - - -pushUnboxedTuple - :: VirtualSpOffset -- Sp at which to start pushing - -> [CAddrMode] -- amodes of the components - -> FCode (VirtualSpOffset, -- final Sp - AbstractC) -- assignments (regs+stack) - -pushUnboxedTuple sp amodes = - let - (arg_regs, _leftovers) = assignRegs [] (map getAmodeRep amodes) - - (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs amodes - - -- 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) - in - - -- 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) -> +returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code +returnUnboxedTuple amodes + = do { eob@(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 } + +pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing + -> [(CgRep, CmmExpr)] -- amodes of the components + -> FCode (VirtualSpOffset, -- final Sp + CmmStmts) -- assignments (regs+stack) + +pushUnboxedTuple sp [] + = return (sp, noStmts) +pushUnboxedTuple sp amodes + = do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs 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, - mkAbstractCs [reg_arg_assts, ptr_assts, nptr_assts]) + ; returnFC (final_sp, + reg_arg_assts `plusStmts` + ptr_assts `plusStmts` nptr_assts) } - -mkUnboxedTupleReturnCode :: Sequel -> Code -mkUnboxedTupleReturnCode sequel - = case sequel of - -- can't update with an unboxed tuple! - UpdateCode -> panic "mkUnboxedTupleReturnCode" - - CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) False -> - absC (CJump (CLbl join_lbl CodePtrRep)) - - 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: @@ -494,44 +338,35 @@ mkUnboxedTupleReturnCode sequel -- (in order to avoid pushing it again), so we end up doing a needless -- indirect jump (ToDo). -ccallReturnUnboxedTuple :: [CAddrMode] -> Code -> Code +ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> 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` + = do { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo - before_jump `thenC` - - returnUnboxedTuple amodes - ) + -- 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 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) +tailCallPrimOp op 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) - reg_arg_assts - = mkAbstractCs (zipWithEqual "assign_to_reg2" - assign_to_reg arg_regs arg_amodes) + ; ASSERT(null leftovers) -- no stack-resident args + emitSimultaneously (assignToRegs arg_regs) - jump_to_primop = - absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep)) - in - - ASSERT(null leftovers) -- no stack-resident args - - getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) -> - doFinalJump args_sp reg_arg_assts False{-not a LNE-} (const jump_to_primop) + ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo + ; doFinalJump args_sp False{-not a LNE-} jump_to_primop } -- ----------------------------------------------------------------------------- -- Return Addresses @@ -551,23 +386,72 @@ tailCallPrimOp op args = pushReturnAddress :: EndOfBlockInfo -> Code -pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _ False)) = - getSpRelOffset args_sp `thenFC` \ sp_rel -> - absC (CAssign (CVal sp_rel RetRep) amode) +pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _ False)) + = 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 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 (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 -- ----------------------------------------------------------------------------- -- Misc. -assign_to_reg reg_id amode = CAssign (CReg reg_id) amode +jumpToLbl :: CLabel -> Code +-- Passes no argument to the destination procedure +jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [{- No args -}]) +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}