summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/Literal.hs81
-rw-r--r--compiler/deSugar/Match.hs45
-rw-r--r--compiler/deSugar/MatchLit.hs43
-rw-r--r--compiler/simplCore/SimplUtils.hs3
-rw-r--r--testsuite/tests/codeGen/should_run/T9533.hs13
-rw-r--r--testsuite/tests/codeGen/should_run/T9533.stdout1
-rw-r--r--testsuite/tests/codeGen/should_run/T9533b.hs8
-rw-r--r--testsuite/tests/codeGen/should_run/T9533b.stdout1
-rw-r--r--testsuite/tests/codeGen/should_run/T9533c.hs8
-rw-r--r--testsuite/tests/codeGen/should_run/T9533c.stdout1
-rw-r--r--testsuite/tests/codeGen/should_run/all.T7
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, [''])
View Lorry Controller Status