diff options
| -rw-r--r-- | compiler/prelude/PrelRules.hs | 64 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 2 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 33 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T15436.hs | 21 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/T15436.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 1 |
6 files changed, 90 insertions, 32 deletions
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index ed81a9481e..78d753525f 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -38,8 +38,9 @@ import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon - , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons ) -import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId ) + , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons + , tyConFamilySize ) +import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, exprIsHNF, exprType ) import CoreUnfold ( exprIsConApp_maybe ) import Type @@ -1929,11 +1930,13 @@ wordPrimOps dflags = PrimOps -- | Match the scrutinee of a case and potentially return a new scrutinee and a -- function to apply to each literal alternative. caseRules :: DynFlags - -> CoreExpr -- Scrutinee - -> Maybe ( CoreExpr -- New scrutinee - , AltCon -> AltCon -- How to fix up the alt pattern - , Id -> CoreExpr) -- How to reconstruct the original scrutinee - -- from the new case-binder + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder -- e.g case e of b { -- ...; -- con bs -> rhs; @@ -1982,9 +1985,9 @@ caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x caseRules _ _ = Nothing -tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon -tx_lit_con _ _ DEFAULT = DEFAULT -tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l) +tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the -- literal alternatives remain in Word/Int target ranges @@ -2024,20 +2027,28 @@ adjustUnary op IntNegOp -> Just (\y -> negate y ) _ -> Nothing -tx_con_tte :: DynFlags -> AltCon -> AltCon -tx_con_tte _ DEFAULT = DEFAULT +tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] - = LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc + = Just $ LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc -tx_con_dtt :: Type -> AltCon -> AltCon -tx_con_dtt _ DEFAULT = DEFAULT +tx_con_dtt :: Type -> AltCon -> Maybe AltCon +tx_con_dtt _ DEFAULT = Just DEFAULT tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) - = DataAlt (get_con ty (fromInteger i)) -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) + | tag >= 0 + , tag < n_data_cons + = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) + | otherwise + = Nothing + where + tag = fromInteger i :: ConTagZ + tc = tyConAppTyCon ty + n_data_cons = tyConFamilySize tc + data_cons = tyConDataCons tc + +tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) -get_con :: Type -> ConTagZ -> DataCon -get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2096,4 +2107,19 @@ headed by a normal tycon. In particular, we do not apply this in the case of a data family tycon, since that would require carefully applying coercion(s) between the data family and the data family instance's representation type, which caseRules isn't currently engineered to handle (#14680). + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alterantive is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out Trac #15436. -} diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 56d624305a..2cb3b0d730 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2950,7 +2950,7 @@ section "Tag to enum stuff" ------------------------------------------------------------------------ primop DataToTagOp "dataToTag#" GenPrimOp - a -> Int# + a -> Int# -- Zero-indexed; the first constructor has tag zero with can_fail = True -- See Note [dataToTag#] strictness = { \ _arity -> mkClosedStrictSig [evalDmd] topRes } diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index e5d9d33899..83ad059171 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -2146,7 +2146,12 @@ mkCase2 dflags scrut bndr alts_ty alts , gopt Opt_CaseFolding dflags , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut = do { bndr' <- newId (fsLit "lwild") (exprType scrut') - ; alts' <- mapM (tx_alt tx_con mk_orig bndr') alts + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in PrelRules + ; mkCase3 dflags scrut' bndr' alts_ty $ add_default (re_sort alts') } @@ -2170,19 +2175,14 @@ mkCase2 dflags scrut bndr alts_ty alts -- to construct an expression equivalent to the original one, for use -- in the DEFAULT case + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) tx_alt tx_con mk_orig new_bndr (con, bs, rhs) - | DataAlt dc <- con', not (isNullaryRepDataCon dc) - = -- For non-nullary data cons we must invent some fake binders - -- See Note [caseRules for dataToTag] in PrelRules - do { us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc - (tyConAppArgs (idType new_bndr)) - ; return (con', ex_tvs ++ arg_ids, rhs') } - | otherwise - = return (con', [], rhs') + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (con', bs', rhs')) } where - con' = tx_con con - rhs' | isDeadBinder bndr = rhs | otherwise = bindNonRec bndr orig_val rhs @@ -2191,6 +2191,15 @@ mkCase2 dflags scrut bndr alts_ty alts LitAlt l -> Lit l DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in PrelRules + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] re_sort :: [CoreAlt] -> [CoreAlt] -- Re-sort the alternatives to re_sort alts = sortBy cmpAlt alts -- preserve the #case_invariants# diff --git a/testsuite/tests/simplCore/should_run/T15436.hs b/testsuite/tests/simplCore/should_run/T15436.hs new file mode 100644 index 0000000000..a9d5df8e09 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T15436.hs @@ -0,0 +1,21 @@ +module Main where + +import GHC.Enum + +data XXX = AL | AK | AZ | AR | CA | CO | CT | DE | FL + deriving (Enum, Bounded, Show) + +data Z = Y | X XXX deriving( Show ) + +instance Enum Z where + fromEnum Y = 0 + fromEnum (X s) = 1 + fromEnum s + toEnum 0 = Y + toEnum i = X (toEnum (i - 1)) + +instance Bounded Z where + minBound = Y + maxBound = X maxBound + + +main = print [ succ (x :: Z) | x <- [minBound .. pred maxBound] ] diff --git a/testsuite/tests/simplCore/should_run/T15436.stdout b/testsuite/tests/simplCore/should_run/T15436.stdout new file mode 100644 index 0000000000..deb6836de6 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T15436.stdout @@ -0,0 +1 @@ +[X AL,X AK,X AZ,X AR,X CA,X CO,X CT,X DE,X FL] diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 99055a34d6..a9edee2b00 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -85,3 +85,4 @@ test('T14868', test('T14894', [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))], compile_and_run, ['']) test('T14965', normal, compile_and_run, ['']) test('T15114', only_ways('optasm'), compile_and_run, ['']) +test('T15436', normal, compile_and_run, ['']) |