X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=b8f3141a770d0552710457def0a5d608a0e8f2d0;hb=2eb04ca0f8d0ec72b417cddc60672c696b4a3daa;hp=7f440c11f2dbefd0d677b1fad4af536b1b92acb4;hpb=7f1bc015a4094a8282ad4090768d780fd4d6122d;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 7f440c1..b8f3141 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -9,7 +9,6 @@ module CgCase ( cgCase, saveVolatileVarsAndRegs, ) where #include "HsVersions.h" -#include "../includes/ClosureTypes.h" import {-# SOURCE #-} CgExpr ( cgExpr ) @@ -42,7 +41,6 @@ import PrimOp import TyCon import Util import Outputable -import Constants \end{code} \begin{code} @@ -173,54 +171,9 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _) _other -> False \end{code} -Special case: scrutinising a non-primitive variable. This is where we -want to do semi-tagging. The code generated will be something like this: - - save volatile vars - R1 = fun - jump c99_ret - - -c99_ret: - infoptr = R1[0] - type = infoptr[-4] // or something - if (type > 8) goto no_cons - tag = infoptr[-6] - if (tag == 1) ... etc. -no_cons - jump infoptr - -\begin{code} -cgCase (StgApp fun []) - live_in_whole_case live_in_alts bndr srt (AlgAlt tycon) alts - = do { fun_info <- getCgIdInfo fun - ; fun_amode <- idInfoToAmode fun_info - - ; nukeDeadBindings live_in_alts - ; (save_assts, alts_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_alts - - ; scrut_eob_info - <- forkEval alts_eob_info - (allocStackTop retAddrSizeW >> nopC) - (do { deAllocStackTop retAddrSizeW - ; cgEvalAltsSemiTag maybe_cc_slot bndr srt - tycon alts }) - - -- jump to the continuation immediately - ; case scrut_eob_info of - EndOfBlockInfo sp (CaseAlts lbl _ _ _) -> do - let node_asst = oneStmt (CmmAssign nodeReg fun_amode) - emitSimultaneously (node_asst `plusStmts` save_assts) - let jmp = stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) - setEndOfBlockInfo scrut_eob_info $ - doFinalJump sp False jmp - } -\end{code} - -Special case: scrutinising a non-primitive application. This can be -done a little better than the general case, because we can reuse/trim -the stack slot holding the variables involved in the application. +Special case: scrutinising a non-primitive variable. +This can be done a little better than the general case, because +we can reuse/trim the stack slot holding the variable (if it is in one). \begin{code} cgCase (StgApp fun args) @@ -244,7 +197,7 @@ cgCase (StgApp fun args) (do { deAllocStackTop retAddrSizeW ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + ; setEndOfBlockInfo scrut_eob_info (performTailCall fun_info arg_amodes save_assts) } \end{code} @@ -281,8 +234,7 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts (do { deAllocStackTop retAddrSizeW ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) - (cgExpr expr) + ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) } \end{code} @@ -312,13 +264,6 @@ consequence of this is that activation records on the stack don't follow the layout of closures when we're profiling. The CCS could be anywhere within the record). -\begin{code} -maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _)) - = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True) -maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info -\end{code} - - %************************************************************************ %* * Inline primops @@ -427,8 +372,8 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts ; restoreCurrentCostCentre cc_slot True ; cgPrimAlts GCMayHappen alt_type reg alts } - ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt - ; returnFC (CaseAlts lbl Nothing bndr False) } + ; lbl <- emitReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr) } cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] = -- Unboxed tuple case @@ -439,7 +384,7 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] ASSERT2( case con of { DataAlt _ -> True; other -> False }, text "cgEvalAlts: dodgy case of unboxed tuple type" ) do { -- forkAbsC for the RHS, so that the envt is - -- not changed for the emitDirectReturn call + -- not changed for the emitReturn call abs_c <- forkProc $ do { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args -- Restore the CC *after* binding the tuple components, @@ -449,61 +394,33 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] -- and finally the code for the alternative ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts (cgExpr rhs) } - ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt - ; returnFC (CaseAlts lbl Nothing bndr False) } + ; lbl <- emitReturnTarget (idName bndr) abs_c srt + ; returnFC (CaseAlts lbl Nothing bndr) } cgEvalAlts cc_slot bndr srt alt_type alts = -- Algebraic and polymorphic case do { -- Bind the default binder bindNewToReg bndr nodeReg (mkLFArgument bndr) + -- Generate sequel info for use downstream + -- At the moment, we only do it if the type is vector-returnable. + -- Reason: if not, then it costs extra to label the + -- alternatives, because we'd get return code like: + -- + -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } + -- + -- which is worse than having the alt code in the switch statement + ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) - alts mb_deflt srt ret_conv + alts mb_deflt srt fam_sz - ; returnFC (CaseAlts lbl branches bndr False) } + ; returnFC (CaseAlts lbl branches bndr) } where - ret_conv = case alt_type of - AlgAlt tc -> ctrlReturnConvAlg tc - PolyAlt -> UnvectoredReturn 0 - - --- Alternatives for a semi-tagging case expression -cgEvalAltsSemiTag cc_slot bndr srt tycon alts - = do -- Bind the default binder - bindNewToReg bndr nodeReg (mkLFArgument bndr) - - blks <- getCgStmts $ cgEvalAltsSemiTag' cc_slot tycon alts - lbl <- emitDirectReturnTarget (idName bndr) blks srt - return (CaseAlts lbl Nothing bndr False) - -cgEvalAltsSemiTag' cc_slot tycon alts - = do - (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot (AlgAlt tycon) alts - - iptr <- newTemp wordRep - stmtC (CmmAssign iptr (closureInfoPtr (CmmReg nodeReg))) - -- share the iptr between ctype and tag, below - - -- we don't have a 1-indexed tag field, we have to use the type - -- field first to find out whether the closure is a constructor - not_constr <- newLabelC - - let highCons = CmmLit (CmmInt CONSTR_NOCAF_STATIC halfWordRep) - stmtC (CmmCondBranch (CmmMachOp (MO_U_Gt halfWordRep) - [infoTableClosureType (infoTable (CmmReg iptr)), - highCons]) - not_constr) - - let tag_expr = CmmMachOp (MO_U_Conv halfWordRep wordRep) - [infoTableConstrTag (infoTable (CmmReg iptr))] - - let family_size = tyConFamilySize tycon - emitSwitch tag_expr alts mb_deflt 0 (family_size - 1) - - labelC not_constr - stmtC (CmmJump (entryCode (CmmReg iptr)) []) + fam_sz = case alt_type of + AlgAlt tc -> tyConFamilySize tc + PolyAlt -> 0 \end{code}