Commit 6dfc5ebf authored by Joachim Breitner's avatar Joachim Breitner Committed by Ben Gamari

Ensure that Literals are in range

This commit fixes several bugs related to case expressions
involving numeric literals which are not in the range of values of
their (fixed-width, integral) type.

There is a new invariant on Literal: The argument of a MachInt[64]
or MachWord[64] must lie within the range of the corresponding
primitive type Int[64]# or Word[64]#, as defined by the target machine.
This invariant is enforced in mkMachInt[64]/mkMachWord[64] by wrapping
the argument to the target type's range if necessary.

Test Plan: Test Plan: make slowtest TEST="T9533 T9533b T9533c T10245
T10246"

Trac issues: #9533, #10245, #10246, #13171

Reviewers: simonmar, simonpj, austin, bgamari, nomeata

Reviewed By: bgamari

Subscribers: thomie, rwbarton

Differential Revision: https://phabricator.haskell.org/D810
parent 0d86aa59
......@@ -13,8 +13,10 @@ module Literal
Literal(..) -- Exported to ParseIface
-- ** Creating Literals
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
, mkMachInt, mkMachIntWrap
, mkMachWord, mkMachWordWrap
, mkMachInt64, mkMachInt64Wrap
, mkMachWord64, mkMachWord64Wrap
, mkMachFloat, mkMachDouble
, mkMachChar, mkMachString
, mkLitInteger
......@@ -52,6 +54,7 @@ import BasicTypes
import Binary
import Constants
import DynFlags
import Platform
import UniqFM
import Util
......@@ -77,6 +80,12 @@ import Numeric ( fromRat )
-- which is presumed to be surrounded by appropriate constructors
-- (@Int#@, etc.), so that the overall thing makes sense.
--
-- We maintain the invariant that the 'Integer' the Mach{Int,Word}*
-- constructors are actually in the (possibly target-dependent) range.
-- The mkMach{Int,Word}*Wrap smart constructors ensure this by applying
-- the target machine's wrapping semantics. Use these in situations
-- where you know the wrapping semantics are correct.
--
-- * The literal derived from the label mentioned in a \"foreign label\"
-- declaration ('MachLabel')
data Literal
......@@ -93,10 +102,10 @@ data Literal
-- that can be represented as a Literal. Create
-- with 'nullAddrLit'
| MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt'
| MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64'
| MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord'
| MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64'
| MachInt Integer -- ^ @Int#@ - according to target machine
| MachInt64 Integer -- ^ @Int64#@ - exactly 64 bits
| MachWord Integer -- ^ @Word#@ - according to target machine
| MachWord64 Integer -- ^ @Word64#@ - exactly 64 bits
| MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat'
| MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
......@@ -218,18 +227,48 @@ mkMachInt :: DynFlags -> Integer -> Literal
mkMachInt dflags x = ASSERT2( inIntRange dflags x, integer x )
MachInt x
-- | Creates a 'Literal' of type @Int#@.
-- If the argument is out of the (target-dependent) range, it is wrapped.
mkMachIntWrap :: DynFlags -> Integer -> Literal
mkMachIntWrap dflags i
= MachInt $ case platformWordSize (targetPlatform dflags) of
4 -> toInteger (fromIntegral i :: Int32)
8 -> toInteger (fromIntegral i :: Int64)
w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
-- | Creates a 'Literal' of type @Word#@
mkMachWord :: DynFlags -> Integer -> Literal
mkMachWord dflags x = ASSERT2( inWordRange dflags x, integer x )
MachWord x
-- | Creates a 'Literal' of type @Word#@.
-- If the argument is out of the (target-dependent) range, it is wrapped.
mkMachWordWrap :: DynFlags -> Integer -> Literal
mkMachWordWrap dflags i
= MachWord $ case platformWordSize (targetPlatform dflags) of
4 -> toInteger (fromInteger i :: Word32)
8 -> toInteger (fromInteger i :: Word64)
w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
-- | Creates a 'Literal' of type @Int64#@
mkMachInt64 :: Integer -> Literal
mkMachInt64 x = MachInt64 x
mkMachInt64 x = ASSERT2( inInt64Range x, integer x )
MachInt64 x
-- | Creates a 'Literal' of type @Int64#@.
-- If the argument is out of the range, it is wrapped.
mkMachInt64Wrap :: Integer -> Literal
mkMachInt64Wrap i = MachInt64 (toInteger (fromIntegral i :: Int64))
-- | Creates a 'Literal' of type @Word64#@
mkMachWord64 :: Integer -> Literal
mkMachWord64 x = MachWord64 x
mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
MachWord64 x
-- | Creates a 'Literal' of type @Word64#@.
-- If the argument is out of the range, it is wrapped.
mkMachWord64Wrap :: Integer -> Literal
mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
-- | Creates a 'Literal' of type @Float#@
mkMachFloat :: Rational -> Literal
......@@ -256,6 +295,12 @@ inIntRange, inWordRange :: DynFlags -> Integer -> Bool
inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags
inInt64Range, inWord64Range :: Integer -> Bool
inInt64Range x = x >= toInteger (minBound :: Int64) &&
x <= toInteger (maxBound :: Int64)
inWord64Range x = x >= toInteger (minBound :: Word64) &&
x <= toInteger (maxBound :: Word64)
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
......@@ -288,16 +333,18 @@ isLitValue_maybe (LitInteger i _) = Just i
isLitValue_maybe _ = Nothing
-- | Apply a function to the 'Integer' contained in the 'Literal', for when that
-- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'.
mapLitValue :: (Integer -> Integer) -> Literal -> Literal
mapLitValue f (MachChar c) = MachChar (fchar c)
-- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
-- fixed-size integral literals, the result will be wrapped in
-- accordance with the semantics of the target type.
mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
mapLitValue _ f (MachChar c) = mkMachChar (fchar c)
where fchar = chr . fromInteger . f . toInteger . ord
mapLitValue f (MachInt i) = MachInt (f i)
mapLitValue f (MachInt64 i) = MachInt64 (f i)
mapLitValue f (MachWord i) = MachWord (f i)
mapLitValue f (MachWord64 i) = MachWord64 (f i)
mapLitValue f (LitInteger i t) = LitInteger (f i) t
mapLitValue _ l = pprPanic "mapLitValue" (ppr l)
mapLitValue dflags f (MachInt i) = mkMachIntWrap dflags (f i)
mapLitValue _ f (MachInt64 i) = mkMachInt64Wrap (f i)
mapLitValue dflags f (MachWord i) = mkMachWordWrap dflags (f i)
mapLitValue _ f (MachWord64 i) = mkMachWord64Wrap (f i)
mapLitValue _ f (LitInteger i t) = mkLitInteger (f i) t
mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l)
-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
-- 'Int', 'Word' and 'LitInteger'.
......
......@@ -45,7 +45,8 @@ import Maybes
import Util
import Name
import Outputable
import BasicTypes ( isGenerated )
import BasicTypes ( isGenerated, fl_value )
import FastString
import Unique
import UniqDFM
......@@ -215,6 +216,7 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
PgLit {} -> matchLiterals vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
PgAny -> matchVariables vars ty (dropGroup eqns)
PgN {} -> matchNPats vars ty (dropGroup eqns)
PgOverS {}-> matchNPats vars ty (dropGroup eqns)
PgNpK {} -> matchNPlusKPats vars ty (dropGroup eqns)
PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo {} -> matchCoercion vars ty (dropGroup eqns)
......@@ -847,8 +849,10 @@ data PatGroup
| PgCon DataCon -- Constructor patterns (incl list, tuple)
| PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
| PgLit Literal -- Literal patterns
| PgN Literal -- Overloaded literals
| PgNpK Literal -- n+k patterns
| PgN Rational -- Overloaded numeric literals;
-- see Note [Don't use Literal for PgN]
| PgOverS FastString -- Overloaded string literals
| PgNpK Integer -- n+k patterns
| PgBang -- Bang patterns
| PgCo Type -- Coercion patterns; the type is the type
-- of the pattern *inside*
......@@ -857,6 +861,26 @@ data PatGroup
Type -- the Type is the type of p (equivalently, the result type of e)
| PgOverloadedList
{- Note [Don't use Literal for PgN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Previously we had, as PatGroup constructors
| ...
| PgN Literal -- Overloaded literals
| PgNpK Literal -- n+k patterns
| ...
But Literal is really supposed to represent an *unboxed* literal, like Int#.
We were sticking the literal from, say, an overloaded numeric literal pattern
into a MachInt constructor. This didn't really make sense; and we now have
the invariant that value in a MachInt must be in the range of the target
machine's Int# type, and an overloaded literal could meaningfully be larger.
Solution: For pattern grouping purposes, just store the literal directly in
the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
for overloaded strings.
-}
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
-- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg
......@@ -937,6 +961,7 @@ sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
-- eqTypes: See Note [Pattern synonym groups]
sameGroup (PgLit _) (PgLit _) = True -- One case expression
sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
sameGroup (PgOverS s1) (PgOverS s2) = s1==s2
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
-- CoPats are in the same goup only if the type of the
......@@ -1066,8 +1091,18 @@ patGroup _ (ConPatOut { pat_con = L _ con
| PatSynCon psyn <- con = PgSyn psyn tys
patGroup _ (WildPat {}) = PgAny
patGroup _ (BangPat {}) = PgBang
patGroup _ (NPat (L _ olit) mb_neg _ _) = PgN (hsOverLitKey olit (isJust mb_neg))
patGroup _ (NPlusKPat _ (L _ olit) _ _ _ _)= PgNpK (hsOverLitKey olit False)
patGroup _ (NPat (L _ OverLit {ol_val=oval}) mb_neg _ _) =
case (oval, isJust mb_neg) of
(HsIntegral _ i, False) -> PgN (fromInteger i)
(HsIntegral _ i, True ) -> PgN (-fromInteger i)
(HsFractional r, False) -> PgN (fl_value r)
(HsFractional r, True ) -> PgN (-fl_value r)
(HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
PgOverS s
patGroup _ (NPlusKPat _ (L _ OverLit {ol_val=oval}) _ _ _ _) =
case oval of
HsIntegral _ i -> PgNpK i
_ -> pprPanic "patGroup NPlusKPat" (ppr oval)
patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
......
......@@ -8,7 +8,7 @@ Pattern-matching literal patterns
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
module MatchLit ( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities, warnAboutEmptyEnumerations
......@@ -375,36 +375,25 @@ matchLiterals [] _ _ = panic "matchLiterals []"
---------------------------
hsLitKey :: DynFlags -> HsLit -> Literal
-- Get a Core literal to use (only) a grouping key
-- Hence its type doesn't need to match the type of the original literal
-- (and doesn't for strings)
-- Get the Core literal corresponding to a HsLit.
-- It only works for primitive types and strings;
-- others have been removed by tidy
hsLitKey dflags (HsIntPrim _ i) = mkMachInt dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWord dflags w
hsLitKey _ (HsInt64Prim _ i) = mkMachInt64 i
hsLitKey _ (HsWord64Prim _ w) = mkMachWord64 w
hsLitKey _ (HsCharPrim _ c) = MachChar c
hsLitKey _ (HsStringPrim _ s) = MachStr s
hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
-- For HsString, it produces a MachStr, which really represents an _unboxed_
-- string literal; and we deal with it in matchLiterals above. Otherwise, it
-- produces a primitive Literal of type matching the original HsLit.
-- In the case of the fixed-width numeric types, we need to wrap here
-- because Literal has an invariant that the literal is in range, while
-- HsLit does not.
hsLitKey dflags (HsIntPrim _ i) = mkMachIntWrap dflags i
hsLitKey dflags (HsWordPrim _ w) = mkMachWordWrap dflags w
hsLitKey _ (HsInt64Prim _ i) = mkMachInt64Wrap i
hsLitKey _ (HsWord64Prim _ w) = mkMachWord64Wrap w
hsLitKey _ (HsCharPrim _ c) = mkMachChar c
hsLitKey _ (HsFloatPrim f) = mkMachFloat (fl_value f)
hsLitKey _ (HsDoublePrim d) = mkMachDouble (fl_value d)
hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)
hsLitKey _ l = pprPanic "hsLitKey" (ppr l)
---------------------------
hsOverLitKey :: HsOverLit a -> Bool -> Literal
-- Ditto for HsOverLit; the boolean indicates to negate
hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
---------------------------
litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral _ i) False = MachInt i
litValKey (HsIntegral _ i) True = MachInt (-i)
litValKey (HsFractional r) False = MachFloat (fl_value r)
litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
litValKey (HsIsString _ s) neg = ASSERT( not neg) MachStr
(fastStringToByteString s)
{-
************************************************************************
* *
......
......@@ -1966,7 +1966,8 @@ mkCase2 dflags scrut bndr alts_ty alts
mapAlt f alt@(c,bs,e) = case c of
DEFAULT -> (c, bs, wrap_rhs scrut e)
LitAlt l
| isLitValue l -> (LitAlt (mapLitValue f l), bs, wrap_rhs (Lit l) e)
| isLitValue l -> (LitAlt (mapLitValue dflags f l),
bs, wrap_rhs (Lit l) e)
_ -> pprPanic "Unexpected alternative (mkCase2)" (ppr alt)
--------------------------------------------------
......
import Data.Word
x :: Word
x = 10
y :: Word
y = 11
test = case x - y of
5 -> "C"
-1 -> "A"
_ -> "B"
main = putStrLn $ show test
-- Test case of known literal with wraparound
test = case 1 :: Int of
0x10000000000000001 -> "A"
_ -> "B"
test2 = case 0x10000000000000001 :: Int of
1 -> "A"
_ -> "B"
main = putStrLn $ test ++ test2
-- Don't wrap literals that will be used at type Integer
f :: Integer -> Int
f n = case n of
0x100000000000000000000000 -> 1
0 -> 2
_ -> 3
main = print (f (read "0"))
......@@ -134,8 +134,11 @@ test('cgrun074', normal, compile_and_run, [''])
test('CmmSwitchTest32', unless(wordsize(32), skip), compile_and_run, [''])
test('CmmSwitchTest64', unless(wordsize(64), skip), compile_and_run, [''])
# Skipping WAY=ghci, because it is not broken.
test('T10245', [omit_ways(['ghci']), expect_broken(10246)], compile_and_run, [''])
test('T10246', expect_broken(10246), compile_and_run, [''])
test('T10245', normal, compile_and_run, [''])
test('T10246', normal, compile_and_run, [''])
test('T9533', normal, compile_and_run, [''])
test('T9533b', normal, compile_and_run, [''])
test('T9533c', normal, compile_and_run, [''])
test('T10414', [only_ways(['threaded2']), extra_ways(['threaded2']), req_smp],
compile_and_run, ['-feager-blackholing'])
test('T10521', 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