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

11 files changed, 159 insertions, 52 deletions

diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index 14ef785905..cc53b47833 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -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'.
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 840a5fe36b..a4aa56e975 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -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
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 9849eec191..2e9a5235bf 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -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)
-
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index 7deaf5bf0c..79a6c610e7 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -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)
 
 --------------------------------------------------
diff --git a/testsuite/tests/codeGen/should_run/T9533.hs b/testsuite/tests/codeGen/should_run/T9533.hs
new file mode 100644
index 0000000000..aaf57a4e43
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533.hs
@@ -0,0 +1,13 @@
+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
diff --git a/testsuite/tests/codeGen/should_run/T9533.stdout b/testsuite/tests/codeGen/should_run/T9533.stdout
new file mode 100644
index 0000000000..d478a3df05
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533.stdout
@@ -0,0 +1 @@
+"A"
diff --git a/testsuite/tests/codeGen/should_run/T9533b.hs b/testsuite/tests/codeGen/should_run/T9533b.hs
new file mode 100644
index 0000000000..84ced19f14
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533b.hs
@@ -0,0 +1,8 @@
+-- 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
diff --git a/testsuite/tests/codeGen/should_run/T9533b.stdout b/testsuite/tests/codeGen/should_run/T9533b.stdout
new file mode 100644
index 0000000000..104cbc4ea9
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533b.stdout
@@ -0,0 +1 @@
+AA
diff --git a/testsuite/tests/codeGen/should_run/T9533c.hs b/testsuite/tests/codeGen/should_run/T9533c.hs
new file mode 100644
index 0000000000..85af8bd5e5
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533c.hs
@@ -0,0 +1,8 @@
+-- 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"))
diff --git a/testsuite/tests/codeGen/should_run/T9533c.stdout b/testsuite/tests/codeGen/should_run/T9533c.stdout
new file mode 100644
index 0000000000..0cfbf08886
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T9533c.stdout
@@ -0,0 +1 @@
+2
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 1895be7fd1..3f88d1389e 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -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, [''])