%
% (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 $
%
%********************************************************
%* *
module CgTailCall (
cgTailCall, performTailCall,
performReturn, performPrimReturn,
- mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
+ emitKnownConReturnCode, emitAlgReturnCode,
returnUnboxedTuple, ccallReturnUnboxedTuple,
- mkPrimReturnCode,
+ pushUnboxedTuple,
tailCallPrimOp,
pushReturnAddress
#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
-- 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
+ }
-- ---------------------------------------------------------------------------
-- 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:
-- (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
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}
projects / ghc-hetmet.git / blobdiff