- -- Adjust stack pointers
- adjustRealSps args_spa args_spb `thenC`
-
- -- 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 -}
-
-
-tailCallBusiness :: Id -> CAddrMode -- Function and its amode
- -> LambdaFormInfo -- Info about the function
- -> [CAddrMode] -- Arguments
- -> StgLiveVars -- Live in continuation
-
- -> 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
-
-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 ->
-
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
-
- 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") [],
- CJump (CMacroExpr CodePtrRep ENTRY_CODE [(CMacroExpr DataPtrRep INFO_PTR [CReg node])])
- ])
- 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
-
- 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
- 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.
-
- mkStkAmodes join_spa join_spb stk_arg_amodes
- `thenFC` \ (final_spa, final_spb, stk_arg_assts) ->
-
- -- Do the simultaneous assignments,
- doSimAssts join_spa live_vars
- (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
- `thenC`
-
- -- Adjust stack ptrs
- adjustRealSps final_spa final_spb `thenC`
-
- -- 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.
-
- -- Do the simultaneous assignments,
- doSimAssts args_spa live_vars
- (mkAbstractCs [pending_assts, node_asst, ret_asst,
- reg_arg_assts, stk_arg_assts])
- `thenC`
-
- -- Final adjustment of stack pointers
- adjustRealSps final_spa final_spb `thenC`
-
- -- Now decide about semi-tagging
- let
- semi_tagging_on = opt_DoSemiTagging
- in
- case (semi_tagging_on, arg_amodes, node_points, sequel) of
-
- --
- -- *************** 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))
- ])
-
- --
- -- *************** The non-semi-tagging case ***************
- --
- other -> absC finish_code
+performPrimReturn :: CgRep -> CmmExpr -- The thing to return
+ -> Code
+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 to do the right sort of jump.
+
+emitKnownConReturnCode :: DataCon -> Code
+emitKnownConReturnCode con
+ = emitAlgReturnCode (dataConTyCon con)
+ (CmmLit (mkIntCLit (dataConTagZ con)))
+ -- emitAlgReturnCode requires zero-indexed tag
+
+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
+
+ -- 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) }
+
+
+-- -----------------------------------------------------------------------------
+-- 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 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)
+
+ ; ASSERT(null leftovers) -- no stack-resident args
+ emitSimultaneously (assignToRegs arg_regs)
+
+ ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
+ ; doFinalJump args_sp False{-not a LNE-} 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 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 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.
+
+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 ]