X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=b0a080e365eb1b62dba710761c5cca42fee05006;hb=fa654d6b16ecda7cc8cb780792ca10ec0e227555;hp=81818228e3c53f93c77b517e73b5b2245e660bcb;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 8181822..b0a080e 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.16 1998/12/02 13:17:52 simonm Exp $ +% $Id: CgTailCall.lhs,v 1.35 2002/10/25 16:54:56 simonpj Exp $ % %******************************************************** %* * @@ -29,31 +29,32 @@ module CgTailCall ( 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 ( mkUpdEntryLabel, mkRtsPrimOpLabel ) +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, panic, assertPanic ) +import Util ( zipWithEqual, splitAtList ) +import ListSetOps ( assocMaybe ) +import Outputable +import Panic ( panic, assertPanic ) \end{code} %************************************************************************ @@ -94,7 +95,7 @@ Case for unboxed @Ids@ first: cgTailCall fun [] | isUnLiftedType (idType fun) = getCAddrMode fun `thenFC` \ amode -> - performPrimReturn amode + performPrimReturn (ppr fun) amode \end{code} The general case (@fun@ is boxed): @@ -109,10 +110,11 @@ cgTailCall fun args = performTailCall fun args %************************************************************************ \begin{code} -performPrimReturn :: CAddrMode -- The thing to return +performPrimReturn :: SDoc -- Just for debugging (sigh) + -> CAddrMode -- The thing to return -> Code -performPrimReturn amode +performPrimReturn doc amode = let kind = getAmodeRep amode ret_reg = dataReturnConvPrim kind @@ -121,11 +123,13 @@ performPrimReturn amode VoidRep -> AbsCNop kind -> (CAssign (CReg ret_reg) amode) in - performReturn assign_possibly mkPrimReturnCode + performReturn assign_possibly (mkPrimReturnCode doc) -mkPrimReturnCode :: Sequel -> Code -mkPrimReturnCode UpdateCode = panic "mkPrimReturnCode: Upd" -mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode -> +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 @@ -141,7 +145,7 @@ mkStaticAlgReturnCode :: DataCon -- The constructor 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` @@ -163,7 +167,7 @@ mkStaticAlgReturnCode con sequel UpdateCode -> -- Ha! We can go direct to the update code, -- (making sure to jump to the *correct* update -- code.) - absC (CReturn (CLbl mkUpdEntryLabel CodePtrRep) + absC (CReturn (CLbl mkUpdInfoLabel CodePtrRep) return_info) CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so @@ -220,7 +224,7 @@ mkDynamicAlgReturnCode tycon dyn_tag sequel = 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)) @@ -261,8 +265,8 @@ performReturn sim_assts finish_code -- 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 @@ -294,14 +298,16 @@ returnUnboxedTuple amodes before_jump 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 FSLIT("TICK_RET_UNBOXED_TUP") [mkIntCLit (length amodes)] `thenC` + doTailCall amodes ret_regs mkUnboxedTupleReturnCode (length leftovers) {- fast args arity -} @@ -312,38 +318,33 @@ returnUnboxedTuple amodes before_jump \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 @@ -357,7 +358,7 @@ tailCallFun fun fun_amode lf_info arg_amodes pending_assts = 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) @@ -383,7 +384,8 @@ doTailCall -> (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 @@ -392,9 +394,7 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts = 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 @@ -415,6 +415,24 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts (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* @@ -432,20 +450,28 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts -- 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 @@ -490,7 +516,7 @@ doTailCall arg_amodes arg_regs finish_code arity pending_assts 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