diff options
-rw-r--r-- | compiler/basicTypes/Literal.hs | 47 | ||||
-rw-r--r-- | compiler/deSugar/Match.hs | 24 | ||||
-rw-r--r-- | compiler/deSugar/MatchLit.hs | 32 | ||||
-rw-r--r-- | compiler/simplCore/SimplUtils.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/codeGen/should_run/all.T | 4 |
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, ['']) |