Ensure that Literals in an Int# case are in rangewip/T10246

This is one way to fix #10246 and #13171. The chosen path involves
adding the invariant that the argument of MachInt/MachWord etc. is
always in the appropriate range, and that the smart constructors for
them (mkMachInt etc.) wrap arguments that are outside the range in the
expected way.

Differential Revision: https://phabricator.haskell.org/D810

5 files changed, 62 insertions, 47 deletions

diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs
index 14ef785905..ed74a54c0a 100644
--- a/compiler/basicTypes/Literal.hs
+++ b/compiler/basicTypes/Literal.hs
@@ -52,8 +52,8 @@ import BasicTypes
 import Binary
 import Constants
 import DynFlags
+import Platform
 import UniqFM
-import Util
 
 import Data.ByteString (ByteString)
 import Data.Int
@@ -77,6 +77,11 @@ 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}* smart constructors ensure this by applying the
+--   exepcted wrapping semantics.
+--
 -- * The literal derived from the label mentioned in a \"foreign label\"
 --   declaration ('MachLabel')
 data Literal
@@ -213,23 +218,33 @@ instance Ord Literal where
         ~~~~~~~~~~~~
 -}
 
--- | Creates a 'Literal' of type @Int#@
+-- | Creates a 'Literal' of type @Int#@.
+--   If the argument is out of the (target-dependent) range, it is wrapped.
 mkMachInt :: DynFlags -> Integer -> Literal
-mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
-                       MachInt x
+mkMachInt 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#@
+--   If the argument is out of the (target-dependent) range, it is wrapped.
 mkMachWord :: DynFlags -> Integer -> Literal
-mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
-                        MachWord x
+mkMachWord 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#@
+--   If the argument is out of the range, it is wrapped.
 mkMachInt64 :: Integer -> Literal
-mkMachInt64  x = MachInt64 x
+mkMachInt64  i = MachInt64 (toInteger (fromIntegral i :: Int64))
 
 -- | Creates a 'Literal' of type @Word64#@
+--   If the argument is out of the range, it is wrapped.
 mkMachWord64 :: Integer -> Literal
-mkMachWord64 x = MachWord64 x
+mkMachWord64 i = MachWord64 (toInteger (fromIntegral i :: Word64))
 
 -- | Creates a 'Literal' of type @Float#@
 mkMachFloat :: Rational -> Literal
@@ -289,15 +304,15 @@ 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)
+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)   = mkMachInt dflags (f i)
+mapLitValue _      f (MachInt64  i)   = mkMachInt64 (f i)
+mapLitValue dflags f (MachWord   i)   = mkMachWord dflags (f i)
+mapLitValue _      f (MachWord64 i)   = mkMachWord64 (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 f5c3cf5066..4b6d6e1e51 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -1046,19 +1046,19 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
 
 patGroup :: DynFlags -> Pat Id -> PatGroup
-patGroup _ (ConPatOut { pat_con = L _ con
+patGroup _      (ConPatOut { pat_con = L _ con
                       , pat_arg_tys = tys })
- | RealDataCon dcon <- con              = PgCon dcon
- | 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 _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList
-patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)
-patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
+ | RealDataCon dcon <- con                   = PgCon dcon
+ | PatSynCon psyn <- con                     = PgSyn psyn tys
+patGroup _      (WildPat {})                 = PgAny
+patGroup _      (BangPat {})                 = PgBang
+patGroup dflags (NPat (L _ olit) mb_neg _ _) = PgN   (hsOverLitKey dflags olit (isJust mb_neg))
+patGroup dflags (NPlusKPat _ (L _ olit) _ _ _ _)= PgNpK (hsOverLitKey dflags olit False)
+patGroup _      (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
+patGroup _      (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
+patGroup _      (ListPat _ _ (Just _))       = PgOverloadedList
+patGroup dflags (LitPat lit)                 = PgLit (hsLitKey dflags lit)
+patGroup _      pat                          = pprPanic "patGroup" (ppr pat)
 
 {-
 Note [Grouping overloaded literal patterns]
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 9849eec191..e083987267 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -382,28 +382,28 @@ hsLitKey :: DynFlags -> HsLit -> Literal
 -- 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)
+hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64       i
+hsLitKey _      (HsWord64Prim _ w) = mkMachWord64      w
+hsLitKey _      (HsCharPrim   _ c) = mkMachChar        c
+hsLitKey _      (HsStringPrim _ s) = MachStr           s
+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
+hsOverLitKey :: DynFlags -> HsOverLit a -> Bool -> Literal
 -- Ditto for HsOverLit; the boolean indicates to negate
-hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg
+hsOverLitKey dflags (OverLit { ol_val = l }) neg = litValKey dflags 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)
+litValKey :: DynFlags -> OverLitVal -> Bool -> Literal
+litValKey dflags (HsIntegral _ i) False = mkMachInt dflags i
+litValKey dflags (HsIntegral _ i) True  = mkMachInt dflags (-i)
+litValKey _      (HsFractional r) False = mkMachFloat (fl_value r)
+litValKey _      (HsFractional r) True  = mkMachFloat (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 2e985c5713..570b4c6df8 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1966,7 +1966,7 @@ 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/all.T b/testsuite/tests/codeGen/should_run/all.T
index 1895be7fd1..a556dac301 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -134,8 +134,8 @@ 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('T10414', [only_ways(['threaded2']), extra_ways(['threaded2']), req_smp],
      compile_and_run, ['-feager-blackholing'])
 test('T10521', normal, compile_and_run, [''])