Commit 9897f678 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent 0f5a63e3
......@@ -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.
-}
......@@ -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 }
......
......@@ -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#
......
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] ]
[X AL,X AK,X AZ,X AR,X CA,X CO,X CT,X DE,X FL]
......@@ -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, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment