X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=f7bcf5ab1765d851a0883b27e5dc26e2b15d71b9;hp=7f440c11f2dbefd0d677b1fad4af536b1b92acb4;hb=0d4d93a38a2aff950bcd12ebb46a2582d68f5de4;hpb=7f1bc015a4094a8282ad4090768d780fd4d6122d diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 7f440c1..f7bcf5a 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 ) @@ -30,7 +29,6 @@ import ClosureInfo import SMRep import CmmUtils import Cmm -import MachOp import StgSyn import StaticFlags @@ -42,7 +40,6 @@ import PrimOp import TyCon import Util import Outputable -import Constants \end{code} \begin{code} @@ -97,7 +94,6 @@ cgCase :: StgExpr -> StgLiveVars -> StgLiveVars -> Id - -> SRT -> AltType -> [StgAlt] -> Code @@ -106,12 +102,12 @@ cgCase :: StgExpr Special case #1: case of literal. \begin{code} -cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt - alt_type@(PrimAlt tycon) alts +cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr + alt_type@(PrimAlt _) alts = do { tmp_reg <- bindNewToTemp bndr ; cm_lit <- cgLit lit - ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit)) - ; cgPrimAlts NoGC alt_type tmp_reg alts } + ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit)) + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } \end{code} Special case #2: scrutinising a primitive-typed variable. No @@ -122,8 +118,8 @@ allocating more heap than strictly necessary, but it will sometimes eliminate a heap check altogether. \begin{code} -cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt - alt_type@(PrimAlt tycon) alts +cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr + alt_type@(PrimAlt _) alts = do { -- Careful! we can't just bind the default binder to the same thing -- as the scrutinee, since it might be a stack location, and having -- two bindings pointing at the same stack locn doesn't work (it @@ -131,15 +127,15 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt v_info <- getCgIdInfo v ; amode <- idInfoToAmode v_info ; tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg amode) - ; cgPrimAlts NoGC alt_type tmp_reg alts } + ; stmtC (CmmAssign (CmmLocal tmp_reg) amode) + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } \end{code} Special case #3: inline PrimOps and foreign calls. \begin{code} -cgCase (StgOpApp op@(StgPrimOp primop) args _) - live_in_whole_case live_in_alts bndr srt alt_type alts +cgCase (StgOpApp (StgPrimOp primop) args _) + _live_in_whole_case live_in_alts bndr alt_type alts | not (primOpOutOfLine primop) = cgInlinePrimOp primop args bndr alt_type live_in_alts alts \end{code} @@ -153,15 +149,15 @@ Special case #4: inline foreign calls: an unsafe foreign call can be done right here, just like an inline primop. \begin{code} -cgCase (StgOpApp op@(StgFCallOp fcall _) args _) - live_in_whole_case live_in_alts bndr srt alt_type alts +cgCase (StgOpApp (StgFCallOp fcall _) args _) + _live_in_whole_case live_in_alts _bndr _alt_type alts | unsafe_foreign_call = ASSERT( isSingleton alts ) do -- *must* be an unboxed tuple alt. -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. { res_tmps <- mapFCs bindNewToTemp non_void_res_ids - ; let res_hints = map (typeHint.idType) non_void_res_ids - ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts + ; let res_hints = map (typeForeignHint.idType) non_void_res_ids + ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts ; cgExpr rhs } where (_, res_ids, _, rhs) = head alts @@ -170,61 +166,16 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _) unsafe_foreign_call = case fcall of CCall (CCallSpec _ _ s) -> not (playSafe s) - _other -> False + _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) - live_in_whole_case live_in_alts bndr srt alt_type alts + _live_in_whole_case live_in_alts bndr alt_type alts = do { fun_info <- getCgIdInfo fun ; arg_amodes <- getArgAmodes args @@ -242,9 +193,9 @@ cgCase (StgApp fun args) <- forkEval alts_eob_info (allocStackTop retAddrSizeW >> nopC) (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) + ; setEndOfBlockInfo scrut_eob_info (performTailCall fun_info arg_amodes save_assts) } \end{code} @@ -262,7 +213,7 @@ deAllocStackTop call is doing above. Finally, here is the general case. \begin{code} -cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts +cgCase expr live_in_whole_case live_in_alts bndr alt_type alts = do { -- Figure out what volatile variables to save nukeDeadBindings live_in_whole_case @@ -279,10 +230,9 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts ; allocStackTop retAddrSizeW -- space for retn address ; nopC }) (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts }) + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) - (cgExpr expr) + ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) } \end{code} @@ -312,13 +262,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 @@ -326,7 +269,10 @@ maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info %************************************************************************ \begin{code} -cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts +cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars + -> [(AltCon, [Id], [Bool], StgExpr)] + -> Code +cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts | isVoidArg (idCgRep bndr) = ASSERT( con == DEFAULT && isSingleton alts && null bs ) do { -- VOID RESULT; just sequencing, @@ -340,9 +286,9 @@ cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts = do { -- PRIMITIVE ALTS, with non-void result tmp_reg <- bindNewToTemp bndr ; cgPrimOp [tmp_reg] primop args live_in_alts - ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts } + ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts } -cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts +cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts = ASSERT( isSingleton alts ) do { -- UNBOXED TUPLE ALTS -- No heap check, no yield, just get in there and do it. @@ -367,10 +313,11 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- Bind the default binder if necessary -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo - ; this_pkg <- getThisPackage ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) }) + ; stmtC (CmmAssign + (CmmLocal tmp_reg) + (tagToClosure tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} @@ -387,11 +334,11 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts (_,e) <- getArgAmode arg return e do_enum_primop primop - = do tmp <- newTemp wordRep + = do tmp <- newTemp bWord cgPrimOp [tmp] primop args live_in_alts - returnFC (CmmReg tmp) + returnFC (CmmReg (CmmLocal tmp)) -cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts +cgInlinePrimOp _ _ bndr _ _ _ = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) \end{code} @@ -408,14 +355,13 @@ is some evaluation to be done. \begin{code} cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any -> Id - -> SRT -- SRT for the continuation -> AltType -> [StgAlt] -> FCode Sequel -- Any addr modes inside are guaranteed -- to be a label so that we can duplicate it -- without risk of duplicating code -cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts +cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts = do { let rep = tyConCgRep tycon reg = dataReturnConvPrim rep -- Bottom for voidRep @@ -427,19 +373,19 @@ 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 + ; returnFC (CaseAlts lbl Nothing bndr) } -cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)] +cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)] = -- Unboxed tuple case -- By now, the simplifier should have have turned it -- into case e of (# a,b #) -> e -- There shouldn't be a -- case e of DEFAULT -> e - ASSERT2( case con of { DataAlt _ -> True; other -> False }, + ASSERT2( case con of { DataAlt _ -> True; _ -> 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 +395,35 @@ 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 + ; returnFC (CaseAlts lbl Nothing bndr) } -cgEvalAlts cc_slot bndr srt alt_type alts +cgEvalAlts cc_slot bndr 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 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 + PrimAlt _ -> panic "cgEvalAlts: PrimAlt" + UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" \end{code} @@ -540,7 +460,7 @@ cgAlgAlts gc_flag cc_slot alt_type alts let mb_deflt = case alts of -- DEFAULT is always first, if present ((DEFAULT,blks) : _) -> Just blks - other -> Nothing + _ -> Nothing branches = [(dataConTagZ con, blks) | (DataAlt con, blks) <- alts] @@ -554,15 +474,16 @@ cgAlgAlt :: GCFlag -> StgAlt -> FCode (AltCon, CgStmts) -cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs) +cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs) = do { abs_c <- getCgStmts $ do { bind_con_args con args ; restoreCurrentCostCentre cc_slot True ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } ; return (con, abs_c) } where - bind_con_args DEFAULT args = nopC + bind_con_args DEFAULT _ = nopC bind_con_args (DataAlt dc) args = bindConArgs dc args + bind_con_args (LitAlt _) _ = panic "cgAlgAlt: LitAlt" \end{code} @@ -603,9 +524,10 @@ cgPrimAlt :: GCFlag -> FCode (AltCon, CgStmts) -- Its compiled form cgPrimAlt gc_flag alt_type (con, [], [], rhs) - = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } ) + = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } ) do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) ; returnFC (con, abs_c) } +cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists" \end{code} @@ -688,6 +610,6 @@ restoreCurrentCostCentre Nothing _freeit = nopC restoreCurrentCostCentre (Just slot) freeit = do { sp_rel <- getSpRelOffset slot ; whenC freeit (freeStackSlots [slot]) - ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) } + ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel bWord)) } \end{code}