diff options
| -rw-r--r-- | compiler/codeGen/CgCase.lhs | 48 |
1 files changed, 24 insertions, 24 deletions
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index cb426f5d2a..f7bcf5ab17 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -4,13 +4,6 @@ % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre ) where @@ -109,8 +102,8 @@ cgCase :: StgExpr Special case #1: case of literal. \begin{code} -cgCase (StgLit lit) live_in_whole_case live_in_alts bndr - 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 (CmmLocal tmp_reg) (CmmLit cm_lit)) @@ -125,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 - 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 @@ -141,8 +134,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr Special case #3: inline PrimOps and foreign calls. \begin{code} -cgCase (StgOpApp op@(StgPrimOp primop) args _) - live_in_whole_case live_in_alts bndr 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} @@ -156,8 +149,8 @@ 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 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. @@ -182,7 +175,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 alt_type alts + _live_in_whole_case live_in_alts bndr alt_type alts = do { fun_info <- getCgIdInfo fun ; arg_amodes <- getArgAmodes args @@ -276,7 +269,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, @@ -292,7 +288,7 @@ cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts ; cgPrimOp [tmp_reg] primop args live_in_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. @@ -342,7 +338,7 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts cgPrimOp [tmp] primop args live_in_alts 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} @@ -386,7 +382,7 @@ cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)] -- 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 @@ -426,6 +422,8 @@ cgEvalAlts cc_slot bndr alt_type alts fam_sz = case alt_type of AlgAlt tc -> tyConFamilySize tc PolyAlt -> 0 + PrimAlt _ -> panic "cgEvalAlts: PrimAlt" + UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" \end{code} @@ -462,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] @@ -476,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} @@ -525,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} |