X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgTailCall.lhs;h=15b2ae249b36c56f8fb2d755fd03dc7d3c9c2fb5;hb=dabfa71f33eabc5a2d10959728f772aa016f1c84;hp=a292b04525a1dac3e8b143ffb9ebb8723237a89b;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index a292b04..15b2ae2 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %******************************************************** %* * @@ -15,41 +15,38 @@ module CgTailCall ( performReturn, mkStaticAlgReturnCode, mkDynamicAlgReturnCode, mkPrimReturnCode, - - tailCallBusiness, - -- and to make the interface self-sufficient... - StgAtom, Id, CgState, CAddrMode, TyCon, - CgInfoDownwards, HeapOffset, Maybe + tailCallBusiness ) where -IMPORT_Trace -import Pretty -- Pretty/Outputable: rm (debugging only) ToDo -import Outputable +import Ubiq{-uitous-} -import StgSyn import CgMonad import AbsCSyn -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, mkAbsCStmts, getAmodeRep ) +import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo ) +import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg, + ctrlReturnConvAlg, CtrlReturnConvention(..), + DataReturnConvention(..) ) 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 CgUsages ( getSpARelOffset ) +import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel ) +import ClosureInfo ( nodeMustPointToIt, + getEntryConvention, EntryConvention(..) ) -import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) -import PrimKind ( retKindSize ) -import Util +import CmdLineOpts ( opt_DoSemiTagging ) +import HeapOffs ( zeroOff, VirtualSpAOffset(..) ) +import Id ( idType, dataConTyCon, dataConTag, + fIRST_TAG + ) +import Literal ( mkMachInt ) +import Maybes ( assocMaybe ) +import PrimRep ( PrimRep(..) ) +import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) ) +import Type ( isPrimType ) +import Util ( zipWithEqual, panic, assertPanic ) \end{code} %************************************************************************ @@ -59,7 +56,7 @@ import Util %************************************************************************ \begin{code} -cgTailCall :: PlainStgAtom -> [PlainStgAtom] -> PlainStgLiveVars -> Code +cgTailCall :: StgArg -> [StgArg] -> StgLiveVars -> Code \end{code} Here's the code we generate for a tail call. (NB there may be no @@ -87,7 +84,7 @@ themselves in an appropriate register and returning to the address on top of the B stack. \begin{code} -cgTailCall (StgLitAtom lit) [] live_vars +cgTailCall (StgLitArg lit) [] live_vars = performPrimReturn (CLit lit) live_vars \end{code} @@ -96,15 +93,15 @@ 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) +cgTailCall atom@(StgVarArg fun) [] live_vars + | isPrimType (idType fun) = getCAddrMode fun `thenFC` \ amode -> performPrimReturn amode live_vars \end{code} The general case (@fun@ is boxed): \begin{code} -cgTailCall (StgVarAtom fun) args live_vars = performTailCall fun args live_vars +cgTailCall (StgVarArg fun) args live_vars = performTailCall fun args live_vars \end{code} %************************************************************************ @@ -134,26 +131,25 @@ KCAH-RDA \begin{code} performPrimReturn :: CAddrMode -- The thing to return - -> PlainStgLiveVars + -> StgLiveVars -> Code performPrimReturn amode live_vars = let - kind = getAmodeKind amode + kind = getAmodeRep amode ret_reg = dataReturnConvPrim kind assign_possibly = case kind of - VoidKind -> AbsCNop + VoidRep -> AbsCNop kind -> (CAssign (CReg ret_reg) amode) in performReturn assign_possibly mkPrimReturnCode live_vars 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 (UpdateCode _) = panic "mkPrimReturnCode: Upd" +mkPrimReturnCode sequel = sequelToAmode sequel `thenFC` \ dest_amode -> + absC (CReturn dest_amode DirectReturn) + -- Direct, no vectoring -- All constructor arguments in registers; Node and InfoPtr are set. -- All that remains is @@ -169,8 +165,8 @@ mkStaticAlgReturnCode :: Id -- The constructor mkStaticAlgReturnCode con maybe_info_lbl sequel = -- Generate profiling code if necessary (case return_convention of - VectoredReturn _ -> profCtrC SLIT("VEC_RETURN") [] - other -> nopC + VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] + other -> nopC ) `thenC` -- Set tag if necessary @@ -194,7 +190,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel -- Set the info pointer, and jump set_info_ptr `thenC` - absC (CJump (CLbl update_label CodePtrKind)) + absC (CJump (CLbl update_label CodePtrRep)) CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so -- we can go right to the alternative @@ -205,7 +201,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel -- is going to handle. case assocMaybe alts tag of - Just (alt_absC, join_lbl) -> absC (CJump (CLbl join_lbl CodePtrKind)) + 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 @@ -218,15 +214,16 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel ) 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 - update_label = case dataReturnConvAlg con of - ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag - ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag + update_label + = case (dataReturnConvAlg con) of + ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag + ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag return_info = case return_convention of UnvectoredReturn _ -> DirectReturn @@ -234,17 +231,17 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel set_info_ptr = case maybe_info_lbl of Nothing -> nopC - Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrKind)) + Just info_lbl -> absC (CAssign (CReg infoptr) (CLbl info_lbl DataPtrRep)) mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> Code mkDynamicAlgReturnCode tycon dyn_tag sequel = case ctrlReturnConvAlg tycon of - VectoredReturn _ -> + VectoredReturn sz -> - profCtrC SLIT("VEC_RETURN") [] `thenC` - sequelToAmode sequel `thenFC` \ ret_addr -> + profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC` + sequelToAmode sequel `thenFC` \ ret_addr -> absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag)) UnvectoredReturn no_of_constrs -> @@ -270,14 +267,14 @@ 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 - -> PlainStgLiveVars + -> StgLiveVars -> Code performReturn sim_assts finish_code live_vars = getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> -- Do the simultaneous assignments, - doSimAssts args_spa live_vars {-UNUSED:live_regs-} sim_assts `thenC` + doSimAssts args_spa live_vars sim_assts `thenC` -- Adjust stack pointers adjustRealSps args_spa args_spb `thenC` @@ -285,23 +282,19 @@ performReturn sim_assts finish_code live_vars -- 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 + -> [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) -> - getAtomAmodes args `thenFC` \ arg_amodes -> + getArgAmodes args `thenFC` \ arg_amodes -> tailCallBusiness fun fun_amode lf_info arg_amodes @@ -311,7 +304,7 @@ performTailCall fun args live_vars tailCallBusiness :: Id -> CAddrMode -- Function and its amode -> LambdaFormInfo -- Info about the function -> [CAddrMode] -- Arguments - -> PlainStgLiveVars -- Live in continuation + -> StgLiveVars -- Live in continuation -> AbstractC -- Pending simultaneous assignments -- *** GUARANTEED to contain only stack assignments. @@ -321,13 +314,9 @@ tailCallBusiness :: Id -> CAddrMode -- Function and its amode -> Code tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts - = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_TAILCALL") IntKind] `thenC` - - isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks -> - - nodeMustPointToIt lf_info `thenFC` \ node_points -> + = nodeMustPointToIt lf_info `thenFC` \ node_points -> getEntryConvention fun lf_info - (map getAmodeKind arg_amodes) `thenFC` \ entry_conv -> + (map getAmodeRep arg_amodes) `thenFC` \ entry_conv -> getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) -> @@ -346,33 +335,25 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts CCallProfCtrMacro SLIT("ENT_VIA_NODE") [], CAssign (CReg infoptr) - (CMacroExpr DataPtrKind INFO_PTR [CReg node]), - CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) + (CMacroExpr DataPtrRep INFO_PTR [CReg node]), + CJump (CMacroExpr CodePtrRep ENTRY_CODE [CReg infoptr]) ]) - StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrKind)) - StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrKind) + StdEntry lbl Nothing -> ([], CJump (CLbl lbl CodePtrRep)) + StdEntry lbl (Just itbl) -> ([], CAssign (CReg infoptr) (CLbl itbl DataPtrRep) `mkAbsCStmts` - CJump (CLbl lbl CodePtrKind)) + CJump (CLbl lbl CodePtrRep)) DirectEntry lbl arity regs -> - (regs, (if do_arity_chks - then CMacroStmt SET_ARITY [mkIntCLit arity] - else AbsCNop) - `mkAbsCStmts` CJump (CLbl lbl CodePtrKind)) + (regs, CJump (CLbl lbl CodePtrRep)) 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 + (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 - assign_to_reg reg_id amode = CAssign (CReg reg_id) amode + 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 @@ -388,7 +369,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts `thenFC` \ (final_spa, final_spb, stk_arg_assts) -> -- Do the simultaneous assignments, - doSimAssts join_spa live_vars {-UNUSED: live_regs-} + doSimAssts join_spa live_vars (mkAbstractCs [pending_assts, reg_arg_assts, stk_arg_assts]) `thenC` @@ -402,7 +383,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts -- 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) -> @@ -411,7 +392,7 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts -- on top, is recorded in final_spb. -- Do the simultaneous assignments, - doSimAssts args_spa live_vars {-UNUSED: live_regs-} + doSimAssts args_spa live_vars (mkAbstractCs [pending_assts, node_asst, ret_asst, reg_arg_assts, stk_arg_assts]) `thenC` @@ -420,7 +401,9 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts adjustRealSps final_spa final_spb `thenC` -- Now decide about semi-tagging - isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on -> + let + semi_tagging_on = opt_DoSemiTagging + in case (semi_tagging_on, arg_amodes, node_points, sequel) of -- @@ -446,41 +429,38 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts -- 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 CodePtrKind) + CJump (CLbl join_lbl CodePtrRep) semi_tagged_alts = [ (mkMachInt (toInteger (tag - fIRST_TAG)), join_details_to_code join_details) | (tag, join_details) <- st_alts ] - -- This alternative is for the unevaluated case; oTHER_TAG is -1 - un_evald_alt = (mkMachInt oTHER_TAG, enter_jump) - - enter_jump = CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) + 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) 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)) ]) @@ -514,12 +494,11 @@ 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) + -> StgLiveVars -- Live in continuation -> AbstractC -> Code -doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts +doSimAssts tail_spa live_vars sim_assts = -- Do the simultaneous assignments absC (CSimultaneous sim_assts) `thenC` @@ -543,6 +522,6 @@ doSimAssts tail_spa live_vars {-UNUSED: live_regs-} sim_assts where stub_A_slot :: VirtualSpAOffset -> Code stub_A_slot offset = getSpARelOffset offset `thenFC` \ spa_rel -> - absC (CAssign (CVal spa_rel PtrKind) + absC (CAssign (CVal spa_rel PtrRep) (CReg StkStubReg)) \end{code}