+-- -----------------------------------------------------------------------------
+-- 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) ->
+
+ 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
+ -- 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)
+
+ in
+ mkStkAmodes sp (stk_args ++ slow_stk_args) `thenFC`
+ \ (final_sp, stk_assts) ->
+
+ 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`
+
+ -- Do the simultaneous assignments,
+ absC (CSimultaneous sim_assts) `thenC`
+
+ -- 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`
+
+ -- 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.
+