%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.19 1999/05/13 17:30:58 simonm Exp $
+% $Id: CgTailCall.lhs,v 1.35 2002/10/25 16:54:56 simonpj Exp $
%
%********************************************************
%* *
import CgMonad
import AbsCSyn
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
import CgRetConv ( dataReturnConvPrim,
ctrlReturnConvAlg, CtrlReturnConvention(..),
assignAllRegs, assignRegs
)
-import CgStackery ( adjustRealSp, mkTaggedStkAmodes, adjustStackHW )
-import CgUsages ( getSpRelOffset )
+import CgStackery ( mkTaggedStkAmodes, adjustStackHW )
+import CgUsages ( getSpRelOffset, adjustSpAndHp )
import CgUpdate ( pushSeqFrame )
import CLabel ( mkUpdInfoLabel, mkRtsPrimOpLabel )
import ClosureInfo ( nodeMustPointToIt,
- getEntryConvention, EntryConvention(..),
- LambdaFormInfo
+ getEntryConvention, EntryConvention(..), LambdaFormInfo
)
import CmdLineOpts ( opt_DoSemiTagging )
import Id ( Id, idType, idName )
import DataCon ( DataCon, dataConTyCon, dataConTag, fIRST_TAG )
-import Const ( mkMachInt )
-import Maybes ( assocMaybe )
+import Maybes ( maybeToBool )
import PrimRep ( PrimRep(..) )
-import StgSyn ( StgArg, GenStgArg(..) )
+import StgSyn ( StgArg )
import Type ( isUnLiftedType )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, splitAtList )
+import ListSetOps ( assocMaybe )
import Outputable
import Panic ( panic, assertPanic )
\end{code}
mkStaticAlgReturnCode con sequel
= -- Generate profiling code if necessary
(case return_convention of
- VectoredReturn sz -> profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz]
+ VectoredReturn sz -> profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz]
other -> nopC
) `thenC`
= case ctrlReturnConvAlg tycon of
VectoredReturn sz ->
- profCtrC SLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
+ profCtrC FSLIT("TICK_VEC_RETURN") [mkIntCLit sz] `thenC`
sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
-- stack location)
pushReturnAddress eob `thenC`
- -- Adjust stack pointer
- adjustRealSp args_sp `thenC`
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
-- Do the return
finish_code sequel -- "sequel" is `robust' in that it doesn't
pushReturnAddress eob `thenC`
setEndOfBlockInfo (EndOfBlockInfo args_sp (OnStack args_sp)) (
- -- Adjust stack pointer
- adjustRealSp args_sp `thenC`
+ -- Adjust Sp/Hp
+ adjustSpAndHp args_sp `thenC`
before_jump `thenC`
let (ret_regs, leftovers) = assignRegs [] (map getAmodeRep amodes)
in
- profCtrC SLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
+ profCtrC FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC`
doTailCall amodes ret_regs
mkUnboxedTupleReturnCode
\end{code}
\begin{code}
-performTailCall :: Id -- Function
- -> [StgArg] -- Args
- -> Code
-
+performTailCall :: Id -> [StgArg] -> 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
+ = 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}
- -> AbstractC -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack
- -- assignments.
+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
+ -> 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 externalised
+ -- (see cgTopRhsClosure).
getEntryConvention (idName fun) lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
let
= case entry_conv of
ViaNode ->
([],
- profCtrC SLIT("TICK_ENT_VIA_NODE") [] `thenC`
+ profCtrC FSLIT("TICK_ENT_VIA_NODE") [] `thenC`
absC (CJump (CMacroExpr CodePtrRep ENTRY_CODE
[CVal (nodeRel 0) DataPtrRep]))
, 0)
-> (Sequel->Code) -- code to perform jump
-> Int -- number of "fast" stack arguments
-> AbstractC -- pending assignments
- -> Maybe VirtualSpOffset -- sp offset to trim stack to
+ -> 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
= getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
let
- no_of_args = length arg_amodes
-
- (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
+ (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs arg_amodes
-- We get some stk_arg_amodes if (a) no regs, or
-- (b) args beyond arity
(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*
-- 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 [pending_assts,
+ -- 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)
- pushReturnAddress eob `thenC`
- -- Final adjustment of stack pointer
- adjustRealSp final_sp `thenC`
+ -- 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
let
enter_jump
-- Enter Node (we know infoptr will have the info ptr in it)!
= mkAbstractCs [
- CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
+ CCallProfCtrMacro FSLIT("RET_SEMI_FAILED")
[CMacroExpr IntRep INFO_TAG [CReg infoptr]],
CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]
in
projects / ghc-hetmet.git / blobdiff