%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgTailCall.lhs,v 1.29 2000/12/06 13:19:49 simonmar Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-#include "HsVersions.h"
-
module CgTailCall (
cgTailCall,
- performReturn,
+ performReturn, performPrimReturn,
mkStaticAlgReturnCode, mkDynamicAlgReturnCode,
+ mkUnboxedTupleReturnCode, returnUnboxedTuple,
mkPrimReturnCode,
-
- tailCallBusiness,
- -- and to make the interface self-sufficient...
- StgAtom, Id, CgState, CAddrMode, TyCon,
- CgInfoDownwards, HeapOffset, Maybe
+ tailCallFun,
+ tailCallPrimOp,
+ doTailCall,
+
+ pushReturnAddress
) where
-IMPORT_Trace
-import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
-import Outputable
+#include "HsVersions.h"
-import StgSyn
import CgMonad
import AbsCSyn
+import PprAbsC ( pprAmode )
-import AbsUniType ( isPrimType, UniType )
-import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgCompInfo ( oTHER_TAG, iND_TAG )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
+import CgRetConv ( dataReturnConvPrim,
+ ctrlReturnConvAlg, CtrlReturnConvention(..),
+ assignAllRegs, assignRegs
)
-import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabelInfo ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
-import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getDataConTyCon, getDataConTag,
- getIdUniType, getIdKind, fIRST_TAG, Id,
- ConTag(..)
+import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
+import CgUsages ( getSpRelOffset, adjustSpAndHp )
+import CgUpdate ( pushSeqFrame )
+import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel,
+ mkBlackHoleInfoTableLabel )
+import ClosureInfo ( nodeMustPointToIt,
+ getEntryConvention, EntryConvention(..), LambdaFormInfo
)
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimKind ( retKindSize )
-import Util
+import CmdLineOpts ( opt_DoSemiTagging )
+import Id ( Id, idType, idName )
+import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
+import Maybes ( maybeToBool )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg )
+import Type ( isUnLiftedType )
+import TyCon ( TyCon )
+import PrimOp ( PrimOp )
+import Util ( zipWithEqual )
+import ListSetOps ( assocMaybe )
+import Outputable
+import Panic ( panic, assertPanic )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code
+cgTailCall :: Id -> [StgArg] -> Code
\end{code}
Here's the code we generate for a tail call. (NB there may be no
\item Adjust the stack high water mark appropriately.
\end{itemize}
-Literals are similar to constructors; they return by putting
-themselves in an appropriate register and returning to the address on
-top of the B stack.
-
-\begin{code}
-cgTailCall (StgLitAtom lit) [] live_vars
- = performPrimReturn (CLit lit) live_vars
-\end{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 @Ids@ first:
\begin{code}
-cgTailCall atom@(StgVarAtom fun) [] live_vars
- | isPrimType (getIdUniType fun)
- = getCAddrMode fun `thenFC` \ amode ->
- performPrimReturn amode live_vars
+cgTailCall fun []
+ | isUnLiftedType (idType fun)
+ = getCAddrMode fun `thenFC` \ amode ->
+ performPrimReturn (ppr fun) amode
\end{code}
The general case (@fun@ is boxed):
\begin{code}
-cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars
+cgTailCall fun args = performTailCall fun args
\end{code}
%************************************************************************
%* *
%************************************************************************
-ADR-HACK
-
- A quick bit of hacking to try to solve my void#-leaking blues...
-
- I think I'm getting bitten by this stuff because code like
-
- \begin{pseudocode}
- case ds.s12 :: IoWorld of {
- -- lvs: [ds.s12]; rhs lvs: []; uniq: c0
- IoWorld ds.s13# -> ds.s13#;
- } :: Universe#
- \end{pseudocode}
-
- causes me to try to allocate a register to return the result in. The
- hope is that the following will avoid such problems (and that Will
- will do this in a cleaner way when he hits the same problem).
-
-KCAH-RDA
-
\begin{code}
-performPrimReturn :: CAddrMode -- The thing to return
- -> PlainStgLiveVars
+performPrimReturn :: SDoc -- Just for debugging (sigh)
+ -> CAddrMode -- The thing to return
-> Code
-performPrimReturn amode live_vars
+performPrimReturn doc amode
= let
- kind = getAmodeKind amode
- ret_reg = dataReturnConvPrim kind
+ kind = getAmodeRep amode
+ ret_reg = WARN( case kind of { PtrRep -> True; other -> False }, text "primRet" <+> doc <+> pprAmode amode )
+ dataReturnConvPrim kind
assign_possibly = case kind of
- VoidKind -> AbsCNop
+ VoidRep -> AbsCNop
kind -> (CAssign (CReg ret_reg) amode)
in
- performReturn assign_possibly mkPrimReturnCode live_vars
+ performReturn assign_possibly (mkPrimReturnCode doc)
-mkPrimReturnCode :: Sequel -> Code
---UNUSED:mkPrimReturnCode RestoreCostCentre = panic "mkPrimReturnCode: RCC"
-mkPrimReturnCode (UpdateCode _) = panic "mkPrimReturnCode: Upd"
-mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode ->
- absC (CReturn dest_amode DirectReturn)
- -- Direct, no vectoring
+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
--- All constructor arguments in registers; Node and InfoPtr are set.
+-- Constructor is built on the heap; Node is set.
-- All that remains is
-- (a) to set TagReg, if necessary
--- (b) to set InfoPtr to the info ptr, if necessary
-- (c) to do the right sort of jump.
-mkStaticAlgReturnCode :: Id -- The constructor
- -> Maybe CLabel -- The info ptr, if it isn't already set
+mkStaticAlgReturnCode :: DataCon -- The constructor
-> Sequel -- where to return to
-> Code
-mkStaticAlgReturnCode con maybe_info_lbl sequel
+mkStaticAlgReturnCode con sequel
= -- Generate profiling code if necessary
(case return_convention of
- VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
+ VectoredReturn sz -> profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz]
other -> nopC
) `thenC`
-- Generate the right jump or return
(case sequel of
- UpdateCode _ -> -- Ha! We know the constructor,
- -- so we can go direct to the correct
- -- update code for that constructor
-
- -- Set the info pointer, and jump
- set_info_ptr `thenC`
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- absC (CJump (CLbl (update_label isw_chkr) CodePtrKind))
+ UpdateCode -> -- Ha! We can go direct to the update code,
+ -- (making sure to jump to the *correct* update
+ -- code.)
+ absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep)
+ return_info)
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
- -- No need to set info ptr when returning to a
- -- known join point. After all, the code at
- -- the destination knows what constructor it
- -- is going to handle.
+ 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
- case assocMaybe alts tag of
- Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind))
- Nothing -> panic "mkStaticAlgReturnCode: default"
- -- The Nothing case should never happen; it's the subject
- -- of a wad of special-case code in cgReturnCon
+ -- can't be a SeqFrame, because we're returning a constructor
- other -> -- OnStack, or (CaseAlts) ret_amode Nothing)
- -- Set the info pointer, and jump
- set_info_ptr `thenC`
+ other -> -- OnStack, or (CaseAlts ret_amode Nothing)
sequelToAmode sequel `thenFC` \ ret_amode ->
absC (CReturn ret_amode return_info)
)
where
- tag = getDataConTag con
- tycon = getDataConTyCon con
+ tag = dataConTag con
+ tycon = dataConTyCon con
return_convention = ctrlReturnConvAlg tycon
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
- -- cf AbsCFuns.mkAlgAltsCSwitch
+ -- cf AbsCUtils.mkAlgAltsCSwitch
+
+ return_info =
+ case return_convention of
+ UnvectoredReturn _ -> DirectReturn
+ VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
- update_label isw_chkr
- = case (dataReturnConvAlg isw_chkr con) of
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
+mkUnboxedTupleReturnCode :: Sequel -> Code
+mkUnboxedTupleReturnCode sequel
+ = case sequel of
+ -- can't update with an unboxed tuple!
+ UpdateCode -> panic "mkUnboxedTupleReturnCode"
- return_info = case return_convention of
- UnvectoredReturn _ -> DirectReturn
- VectoredReturn _ -> StaticVectoredReturn zero_indexed_tag
+ CaseAlts _ (Just ([(_,(alt_absC,join_lbl))], _)) ->
+ absC (CJump (CLbl join_lbl CodePtrRep))
- set_info_ptr = case maybe_info_lbl of
- Nothing -> nopC
- Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind))
+ -- can't be a SeqFrame
+ other -> -- OnStack, or (CaseAlts ret_amode something)
+ sequelToAmode sequel `thenFC` \ ret_amode ->
+ absC (CReturn ret_amode DirectReturn)
+
+-- This function is used by PrimOps that return enumerated types (i.e.
+-- all the comparison operators).
mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code
= case ctrlReturnConvAlg tycon of
VectoredReturn sz ->
- profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
- sequelToAmode sequel `thenFC` \ ret_addr ->
+ profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
+ sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
UnvectoredReturn no_of_constrs ->
-> (Sequel -> Code) -- The code to execute to actually do
-- the return, given an addressing mode
-- for the return address
- -> PlainStgLiveVars
-> Code
-performReturn sim_assts finish_code live_vars
- = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+-- this is just a special case of doTailCall, later.
+performReturn sim_assts finish_code
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
-- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts `thenC`
+ doSimAssts sim_assts `thenC`
- -- Adjust stack pointers
- adjustRealSps args_spa args_spb `thenC`
+ -- push a return address if necessary
+ -- (after the assignments above, in case we clobber a live
+ -- stack location)
+ pushReturnAddress eob `thenC`
+
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
-- depend on stk-ptr values
--- where
---UNUSED: live_regs = getDestinationRegs sim_assts
- -- ToDo: this is a *really* boring way to compute the
- -- live-reg set!
\end{code}
-\begin{code}
-performTailCall :: Id -- Function
- -> [PlainStgAtom] -- Args
- -> PlainStgLiveVars
- -> Code
+Returning unboxed tuples. This is mainly to support _ccall_GC_, where
+we want to do things in a slightly different order to normal:
-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) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ - push return address
+ - adjust stack pointer
+ - r = call(args...)
+ - assign regs for unboxed tuple (usually just R1 = r)
+ - return to continuation
- tailCallBusiness
- fun fun_amode lf_info arg_amodes
- live_vars AbsCNop {- No pending assignments -}
+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).
-tailCallBusiness :: Id -> CAddrMode -- Function and its amode
- -> LambdaFormInfo -- Info about the function
- -> [CAddrMode] -- Arguments
- -> PlainStgLiveVars -- Live in continuation
+\begin{code}
+returnUnboxedTuple :: [CAddrMode] -> Code -> Code
+returnUnboxedTuple amodes before_jump
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- -> 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
+ -- push a return address if necessary
+ pushReturnAddress eob `thenC`
+ setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
- -> Code
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
-tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
+ before_jump `thenC`
- nodeMustPointToIt lf_info `thenFC` \ node_points ->
- getEntryConvention fun lf_info
- (map getAmodeKind arg_amodes) `thenFC` \ entry_conv ->
+ let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
+ in
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+ profCtrC SLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
+ doTailCall amodes ret_regs
+ mkUnboxedTupleReturnCode
+ (length leftovers) {- fast args arity -}
+ AbsCNop {-no pending assigments-}
+ Nothing {-not a let-no-escape-}
+ False {-node doesn't point-}
+ )
+\end{code}
+
+\begin{code}
+performTailCall :: Id -> [StgArg] -> Code
+performTailCall fun args
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
+ tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
+\end{code}
+
+Generating code for a tail call to a function (or closure)
+
+\begin{code}
+tailCallFun
+ :: Id -- Function
+ -> CAddrMode
+ -> LambdaFormInfo
+ -> [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 ->
+ -- we use the name of fun', the Id from the environment, rather than
+ -- fun from the STG tree, in case it is a top-level name that we globalised
+ -- (see cgTopRhsClosure).
+ getEntryConvention (idName fun) lf_info
+ (map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
let
node_asst
= if node_points then
else
AbsCNop
- (arg_regs, finish_code)
+ (arg_regs, finish_code, arity)
= case entry_conv of
- ViaNode ->
+ ViaNode ->
([],
- mkAbstractCs [
- CCallProfCtrMacro SLIT("ENT_VIA_NODE") [],
- CAssign (CReg infoptr)
-
- (CMacroExpr DataPtrKind INFO_PTR [CReg node]),
- CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
- ])
- StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind))
- StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind)
- `mkAbsCStmts`
- CJump (CLbl lbl CodePtrKind))
+ 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, (if do_arity_chks
- then CMacroStmt SET_ARITY [mkIntCLit arity]
- else AbsCNop)
- `mkAbsCStmts` CJump (CLbl lbl CodePtrKind))
-
- no_of_args = length arg_amodes
-
-{- UNUSED: live_regs = if node_points then
- node : arg_regs
- else
- arg_regs
--}
- (reg_arg_assts, stk_arg_amodes)
- = (mkAbstractCs (zipWith assign_to_reg arg_regs arg_amodes),
- drop (length arg_regs) arg_amodes) -- No regs, or
- -- args beyond arity
-
- assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
+ (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
- case fun_amode of
- CJoinPoint join_spa join_spb -> -- Ha! A let-no-escape thingy
+ doTailCall arg_amodes arg_regs (const finish_code) arity
+ (mkAbstractCs [node_asst,pending_assts]) join_sp node_points
- 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) ->
+-- this generic tail call code is used for both function calls and returns.
- -- Do the simultaneous assignments,
- doSimAssts join_spa live_vars {-UNUSED: live_regs-}
- (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts])
- `thenC`
+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
- -- Adjust stack ptrs
- adjustRealSps final_spa final_spb `thenC`
+doTailCall arg_amodes arg_regs finish_code arity pending_assts
+ maybe_join_sp node_points
+ = getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
- -- Jump to join point
- absC finish_code
+ 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
- _ -> -- else: not a let-no-escape (the common case)
+ reg_arg_assts
+ = mkAbstractCs (zipWithEqual "assign_to_reg2"
+ assign_to_reg arg_regs reg_arg_amodes)
- -- 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) ->
+ assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
- -- The B-stack space for the pushed return addess, with any args pushed
- -- on top, is recorded in final_spb.
+ 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) ->
- -- Do the simultaneous assignments,
- doSimAssts args_spa live_vars {-UNUSED: live_regs-}
- (mkAbstractCs [pending_assts, node_asst, ret_asst,
- reg_arg_assts, stk_arg_assts])
- `thenC`
+ mkTaggedStkAmodes fast_sp fast_stk_amodes `thenFC`
+ \ (final_sp, fast_arg_assts, _) ->
- -- Final adjustment of stack pointers
- adjustRealSps final_spa final_spb `thenC`
+ -- 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`
+
-- Now decide about semi-tagging
- isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
- case (semi_tagging_on, arg_amodes, node_points, sequel) of
+ let
+ semi_tagging_on = opt_DoSemiTagging
+ in
+ case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
-- *************** The semi-tagging case ***************
--
+ {- XXX leave this out for now.
( True, [], True, CaseAlts _ (Just (st_alts, maybe_deflt_join_details))) ->
-- Whoppee! Semi-tagging rules OK!
let
join_details_to_code (load_regs_and_profiling_code, join_lbl)
= load_regs_and_profiling_code `mkAbsCStmts`
- CJump (CLbl join_lbl CodePtrKind)
+ CJump (CLbl join_lbl CodePtrRep)
- semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)),
+ semi_tagged_alts = [ (mkMachInt (fromInt (tag - fIRST_TAG)),
join_details_to_code join_details)
| (tag, join_details) <- st_alts
]
-- Enter Node (we know infoptr will have the info ptr in it)!
= mkAbstractCs [
CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
- [CMacroExpr IntKind INFO_TAG [CReg infoptr]],
- CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) ]
+ [CMacroExpr IntRep INFO_TAG [CReg infoptr]],
+ CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
in
-- Final switch
absC (mkAbstractCs [
CAssign (CReg infoptr)
- (CVal (NodeRel zeroOff) DataPtrKind),
+ (CVal (NodeRel zeroOff) DataPtrRep),
case maybe_deflt_join_details of
Nothing ->
- CSwitch (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(enter_jump)
Just (_, details) ->
- CSwitch (CMacroExpr IntKind EVAL_TAG [CReg infoptr])
+ CSwitch (CMacroExpr IntRep EVAL_TAG [CReg infoptr])
[(mkMachInt 0, enter_jump)]
(CSwitch
- (CMacroExpr IntKind INFO_TAG [CReg infoptr])
+ (CMacroExpr IntRep INFO_TAG [CReg infoptr])
(semi_tagged_alts)
(join_details_to_code details))
])
+ -}
--
-- *************** The non-semi-tagging case ***************
--
- other -> absC finish_code
+ other -> finish_code sequel
\end{code}
-\begin{code}
-loadRetAddrIntoRetReg :: Sequel -> FCode AbstractC
-
-loadRetAddrIntoRetReg InRetReg
- = returnFC AbsCNop -- Return address already there
-
-loadRetAddrIntoRetReg sequel
- = sequelToAmode sequel `thenFC` \ amode ->
- returnFC (CAssign (CReg RetReg) amode)
+%************************************************************************
+%* *
+\subsection[tailCallPrimOp]{@tailCallPrimOp@}
+%* *
+%************************************************************************
+\begin{code}
+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)
+ in
+ ASSERT(null leftovers) -- no stack-resident args
+ doTailCall arg_amodes arg_regs
+ (const (absC (CJump (CLbl (mkRtsPrimOpLabel op) CodePtrRep))))
+ 0 {- arity shouldn't matter, all args in regs -}
+ AbsCNop {- no pending assignments -}
+ Nothing {- not a let-no-escape -}
+ False {- node doesn't point -}
\end{code}
%************************************************************************
They are separate because we sometimes do some jiggery-pokery in between.
\begin{code}
-doSimAssts :: VirtualSpAOffset -- tail_spa: SpA as seen by continuation
- -> PlainStgLiveVars -- Live in continuation
---UNUSED: -> [MagicId] -- Live regs (ptrs and non-ptrs)
- -> AbstractC
- -> Code
-
-doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts
- = -- Do the simultaneous assignments
- absC (CSimultaneous sim_assts) `thenC`
-
- -- Stub any unstubbed slots; the only live variables are indicated in
- -- the end-of-block info in the monad
- nukeDeadBindings live_vars `thenC`
- getUnstubbedAStackSlots tail_spa `thenFC` \ a_slots ->
- -- Passing in tail_spa here should actually be redundant, because
- -- the stack should be trimmed (by nukeDeadBindings) to
- -- exactly the tail_spa position anyhow.
-
- -- Emit code to stub dead regs; this only generates actual
- -- machine instructions in in the DEBUG version
- -- *** NOT DONE YET ***
-
- (if (null a_slots)
- then nopC
- else profCtrC SLIT("A_STK_STUB") [mkIntCLit (length a_slots)] `thenC`
- mapCs stub_A_slot a_slots
- )
- where
- stub_A_slot :: VirtualSpAOffset -> Code
- stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel ->
- absC (CAssign (CVal spa_rel PtrKind)
- (CReg StkStubReg))
+doSimAssts :: AbstractC -> Code
+
+doSimAssts sim_assts
+ = absC (CSimultaneous sim_assts)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[retAddr]{@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.
+
+\begin{code}
+pushReturnAddress :: EndOfBlockInfo -> Code
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts amode _)) =
+ getSpRelOffset args_sp `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) amode)
+pushReturnAddress (EndOfBlockInfo args_sp sequel@(SeqFrame amode _)) =
+ pushSeqFrame args_sp `thenFC` \ ret_sp ->
+ getSpRelOffset ret_sp `thenFC` \ sp_rel ->
+ absC (CAssign (CVal sp_rel RetRep) amode)
+pushReturnAddress _ = nopC
\end{code}
projects / ghc-hetmet.git / blobdiff