-\begin{code}
-performTailCall :: Id -- Function
- -> [StgArg] -- Args
- -> Code
-
-performTailCall fun args
- = -- 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 ->
-
- tailCallFun
- fun fun_amode lf_info arg_amodes
- AbsCNop {- No pending assignments -}
-
-
--- generating code for a tail call to a function (or closure)
-
-tailCallFun :: Id -> CAddrMode -- Function and its amode
- -> LambdaFormInfo -- Info about the function
- -> [CAddrMode] -- Arguments
-
- -> 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
-
-tailCallFun fun fun_amode lf_info arg_amodes pending_assts
- = nodeMustPointToIt lf_info `thenFC` \ node_points ->
- getEntryConvention (idName fun) lf_info
- (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
- let
- node_asst
- = if node_points then
- CAssign (CReg node) fun_amode
- else
- AbsCNop
-
- (arg_regs, finish_code, arity)
- = case entry_conv of
- ViaNode ->
- ([],
- profCtrC SLIT("TICK_ENT_VIA_NODE") [] `thenC`
- absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
- [CVal (nodeRel 0) DataPtrRep]))
- , 0)
- StdEntry lbl -> ([], absC (CJump (CLbl lbl CodePtrRep)), 0)
- DirectEntry lbl arity regs ->
- (regs, absC (CJump (CLbl lbl CodePtrRep)),
- arity - length regs)
-
- -- set up for a let-no-escape if necessary
- join_sp = case fun_amode of
- CJoinPoint sp -> Just sp
- other -> Nothing
- in
- doTailCall arg_amodes arg_regs (const finish_code) arity
- (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
-
-
--- this generic tail call code is used for both function calls and returns.
-
-doTailCall
- :: [CAddrMode] -- args to pass to function
- -> [MagicId] -- registers to use
- -> (Sequel->Code) -- code to perform jump
- -> Int -- number of "fast" stack arguments
- -> AbstractC -- pending assignments
- -> Maybe VirtualSpOffset -- sp offset to trim stack to:
- -- USED iff destination is a let-no-escape
- -> Bool -- node points to the closure to enter
- -> Code
-
-doTailCall arg_amodes arg_regs finish_code arity pending_assts
- maybe_join_sp node_points
- = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-
- let
- (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
-
- 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
-
- join_sp = case maybe_join_sp of
- Just sp -> ASSERT(not (args_sp > sp)) sp
- -- If ASSERTion fails: Oops: the join point has *lower*
- -- stack ptrs than the continuation Note that we take
- -- the Sp point without the return address here. The
- -- return address is put on by the let-no-escapey thing
- -- when it finishes.
- Nothing -> args_sp
-
- (fast_stk_amodes, tagged_stk_amodes) =
- splitAt arity stk_arg_amodes
-
- -- eager blackholing, at the end of the basic block.
- (r1_tmp_asst, bh_asst)
- = case sequel of
-#if 0
- -- no: UpdateCode doesn't tell us that we're in a thunk's entry code.
- -- we might be in a case continuation later down the line. Also,
- -- we might have pushed a return address on the stack, if we're in
- -- a case scrut, and still be in the thunk's entry code.
- UpdateCode ->
- (CAssign node_save nodeReg,
- CAssign (CVal (CIndex node_save (mkIntCLit 0) PtrRep)
- PtrRep)
- (CLbl mkBlackHoleInfoTableLabel DataPtrRep))
- where
- node_save = CTemp (mkPseudoUnique1 2) DataPtrRep
-#endif
- _ -> (AbsCNop, AbsCNop)
- in
- -- We can omit tags on the arguments passed to the fast entry point,
- -- but we have to be careful to fill in the tags on any *extra*
- -- arguments we're about to push on the stack.
-
- mkTaggedStkAmodes join_sp tagged_stk_amodes `thenFC`
- \ (fast_sp, tagged_arg_assts, tag_assts) ->
-
- mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
- \ (final_sp, fast_arg_assts, _) ->
-
- -- adjust the high-water mark if necessary
- adjustStackHW final_sp `thenC`
-
- -- The stack space for the pushed return addess,
- -- with any args pushed on top, is recorded in final_sp.
-
- -- Do the simultaneous assignments,
- doSimAssts (mkAbstractCs [r1_tmp_asst,
- pending_assts,
- reg_arg_assts,
- fast_arg_assts,
- tagged_arg_assts,
- tag_assts]) `thenC`
- absC bh_asst `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.
- (if (maybeToBool maybe_join_sp)
- then nopC
- else pushReturnAddress eob) `thenC`
-
- -- Final adjustment of Sp/Hp
- adjustSpAndHp final_sp `thenC`
+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
+
+-- 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 { 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