Fix PrelRules.caseRules to account for out-of-range tags

As Trac #15436 points out, it is possible to get
   case dataToTag# (x :: T) of
      DEFAULT -> blah1
      -1#     -> blah2
      0       -> blah3

The (-1#) alterantive is unreachable, because dataToTag# returns
tags in the range [0..n-1] where n is the number of data constructors
in type T.

This actually made GHC crash; now we simply discard the unreachable
alterantive.  See Note [Unreachable caseRules alternatives]
in PrelRules

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, [''])