X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCase.lhs;h=057f58d7e6398f0110fb11762c30e79cc5a40051;hp=b8f3141a770d0552710457def0a5d608a0e8f2d0;hb=cbbee4e8727c583daf32d9bf17f00afaa839ef10;hpb=9ff76535edb25ab7434284adddb5c64708ecb547 diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index b8f3141..057f58d 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -29,7 +29,6 @@ import ClosureInfo import SMRep import CmmUtils import Cmm -import MachOp import StgSyn import StaticFlags @@ -38,9 +37,12 @@ import ForeignCall import VarSet import CoreSyn import PrimOp +import Type import TyCon import Util import Outputable + +import Control.Monad (when) \end{code} \begin{code} @@ -95,7 +97,6 @@ cgCase :: StgExpr -> StgLiveVars -> StgLiveVars -> Id - -> SRT -> AltType -> [StgAlt] -> Code @@ -104,12 +105,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 @@ -120,24 +121,47 @@ 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 - = do { -- Careful! we can't just bind the default binder to the same thing +cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr + alt_type@(PrimAlt _) alts + -- Note [ticket #3132]: we might be looking at a case of a lifted Id + -- that was cast to an unlifted type. The Id will always be bottom, + -- but we don't want the code generator to fall over here. If we + -- just emit an assignment here, the assignment will be + -- type-incorrect Cmm. Hence we check that the types match, and if + -- they don't we'll fall through and emit the usual enter/return + -- code. Test case: codeGen/should_compile/3132.hs + | isUnLiftedType (idType v) + + -- However, we also want to allow an assignment to be generated + -- in the case when the types are compatible, because this allows + -- some slightly-dodgy but occasionally-useful casts to be used, + -- such as in RtClosureInspect where we cast an HValue to a MutVar# + -- so we can print out the contents of the MutVar#. If we generate + -- code that enters the HValue, then we'll get a runtime panic, because + -- the HValue really is a MutVar#. The types are compatible though, + -- so we can just generate an assignment. + || reps_compatible + = + 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 -- confuses nukeDeadBindings). Hence, use a new temp. - v_info <- getCgIdInfo v + when (not reps_compatible) $ + panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" + ; 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 } + where + reps_compatible = idCgRep v == idCgRep bndr \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} @@ -151,15 +175,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 @@ -168,7 +192,7 @@ 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. @@ -177,7 +201,7 @@ 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 @@ -195,7 +219,7 @@ 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 scrut_eob_info (performTailCall fun_info arg_amodes save_assts) } @@ -215,7 +239,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 @@ -232,7 +256,7 @@ 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 scrut_eob_info (cgExpr expr) } @@ -271,7 +295,10 @@ anywhere within the record). %************************************************************************ \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, @@ -285,9 +312,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. @@ -312,10 +339,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-} @@ -332,11 +360,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} @@ -353,14 +381,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 @@ -372,16 +399,16 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts ; restoreCurrentCostCentre cc_slot True ; cgPrimAlts GCMayHappen alt_type reg alts } - ; lbl <- emitReturnTarget (idName bndr) abs_c srt + ; 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 emitReturn call @@ -394,10 +421,10 @@ 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 <- emitReturnTarget (idName bndr) abs_c srt + ; 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) @@ -414,13 +441,15 @@ cgEvalAlts cc_slot bndr srt alt_type alts ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) - alts mb_deflt srt fam_sz + alts mb_deflt fam_sz ; returnFC (CaseAlts lbl branches bndr) } where fam_sz = case alt_type of AlgAlt tc -> tyConFamilySize tc PolyAlt -> 0 + PrimAlt _ -> panic "cgEvalAlts: PrimAlt" + UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" \end{code} @@ -457,7 +486,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] @@ -471,15 +500,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} @@ -520,9 +550,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} @@ -605,6 +636,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}