diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index f8b8f91bcc570772f2097c369176ffd1de06f60d..7111c7b07a3124c9f6a99bd6734dbe1b50b8fa8b 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -474,12 +474,11 @@ shiftRule shift_op ; case e1 of _ | shift_len == 0 -> return e1 - | shift_len < 0 || wordSizeInBits dflags < shift_len - -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy - ("Bad shift length" ++ show shift_len)) -- Do the shift at type Integer, but shift length is Int Lit (LitNumber nt x t) + | 0 < shift_len + , shift_len <= wordSizeInBits dflags -> let op = shift_op dflags y = x `op` fromInteger shift_len in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 4226f8e967536a04260db7fce8def24e282e9dc2..000e663b83082e788c692b8d1b2925e2cd97359e 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -205,7 +205,8 @@ class Eq a => Bits a where x `complementBit` i = x `xor` bit i {-| Shift the argument left by the specified number of bits - (which must be non-negative). + (which must be non-negative). Some instances may throw an + 'Control.Exception.Overflow' exception if given a negative input. An instance can define either this and 'shiftR' or the unified 'shift', depending on which is more convenient for the type in @@ -227,7 +228,8 @@ class Eq a => Bits a where {-| Shift the first argument right by the specified number of bits. The result is undefined for negative shift amounts and shift amounts - greater or equal to the 'bitSize'. + greater or equal to the 'bitSize'. Some instances may throw an + 'Control.Exception.Overflow' exception if given a negative input. Right shifts perform sign extension on signed number types; i.e. they fill the top bits with 1 if the @x@ is negative @@ -450,9 +452,13 @@ instance Bits Int where (I# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) | otherwise = I# (x# `iShiftRA#` negateInt# i#) - (I# x#) `shiftL` (I# i#) = I# (x# `iShiftL#` i#) + (I# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftL#` i#) + | otherwise = overflowError (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#) - (I# x#) `shiftR` (I# i#) = I# (x# `iShiftRA#` i#) + (I# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I# (x# `iShiftRA#` i#) + | otherwise = overflowError (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#) {-# INLINE rotate #-} -- See Note [Constant folding for rotate] @@ -488,9 +494,13 @@ instance Bits Word where (W# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) | otherwise = W# (x# `shiftRL#` negateInt# i#) - (W# x#) `shiftL` (I# i#) = W# (x# `shiftL#` i#) + (W# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftL#` i#) + | otherwise = overflowError (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#) - (W# x#) `shiftR` (I# i#) = W# (x# `shiftRL#` i#) + (W# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W# (x# `shiftRL#` i#) + | otherwise = overflowError (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#) (W# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W# x# diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index d74b9e211c2faa0fb6f6ef839c3830a0da6862fe..2c5ca9d5a8fea857361feb988eddf5674e70b614 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -185,9 +185,13 @@ instance Bits Int8 where (I8# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I8# (narrow8Int# (x# `iShiftL#` i#)) | otherwise = I8# (x# `iShiftRA#` negateInt# i#) - (I8# x#) `shiftL` (I# i#) = I8# (narrow8Int# (x# `iShiftL#` i#)) + (I8# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I8# (narrow8Int# (x# `iShiftL#` i#)) + | otherwise = overflowError (I8# x#) `unsafeShiftL` (I# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#)) - (I8# x#) `shiftR` (I# i#) = I8# (x# `iShiftRA#` i#) + (I8# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I8# (x# `iShiftRA#` i#) + | otherwise = overflowError (I8# x#) `unsafeShiftR` (I# i#) = I8# (x# `uncheckedIShiftRA#` i#) (I8# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) @@ -385,9 +389,13 @@ instance Bits Int16 where (I16# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I16# (narrow16Int# (x# `iShiftL#` i#)) | otherwise = I16# (x# `iShiftRA#` negateInt# i#) - (I16# x#) `shiftL` (I# i#) = I16# (narrow16Int# (x# `iShiftL#` i#)) + (I16# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I16# (narrow16Int# (x# `iShiftL#` i#)) + | otherwise = overflowError (I16# x#) `unsafeShiftL` (I# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` i#)) - (I16# x#) `shiftR` (I# i#) = I16# (x# `iShiftRA#` i#) + (I16# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I16# (x# `iShiftRA#` i#) + | otherwise = overflowError (I16# x#) `unsafeShiftR` (I# i#) = I16# (x# `uncheckedIShiftRA#` i#) (I16# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) @@ -587,10 +595,14 @@ instance Bits Int32 where (I32# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I32# (narrow32Int# (x# `iShiftL#` i#)) | otherwise = I32# (x# `iShiftRA#` negateInt# i#) - (I32# x#) `shiftL` (I# i#) = I32# (narrow32Int# (x# `iShiftL#` i#)) + (I32# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I32# (narrow32Int# (x# `iShiftL#` i#)) + | otherwise = overflowError (I32# x#) `unsafeShiftL` (I# i#) = I32# (narrow32Int# (x# `uncheckedIShiftL#` i#)) - (I32# x#) `shiftR` (I# i#) = I32# (x# `iShiftRA#` i#) + (I32# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I32# (x# `iShiftRA#` i#) + | otherwise = overflowError (I32# x#) `unsafeShiftR` (I# i#) = I32# (x# `uncheckedIShiftRA#` i#) (I32# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) @@ -821,9 +833,13 @@ instance Bits Int64 where (I64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I64# (x# `iShiftL64#` i#) | otherwise = I64# (x# `iShiftRA64#` negateInt# i#) - (I64# x#) `shiftL` (I# i#) = I64# (x# `iShiftL64#` i#) + (I64# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I64# (x# `iShiftL64#` i#) + | otherwise = overflowError (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL64#` i#) - (I64# x#) `shiftR` (I# i#) = I64# (x# `iShiftRA64#` i#) + (I64# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I64# (x# `iShiftRA64#` i#) + | otherwise = overflowError (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA64#` i#) (I64# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) @@ -994,9 +1010,13 @@ instance Bits Int64 where (I64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = I64# (x# `iShiftL#` i#) | otherwise = I64# (x# `iShiftRA#` negateInt# i#) - (I64# x#) `shiftL` (I# i#) = I64# (x# `iShiftL#` i#) + (I64# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = I64# (x# `iShiftL#` i#) + | otherwise = overflowError (I64# x#) `unsafeShiftL` (I# i#) = I64# (x# `uncheckedIShiftL#` i#) - (I64# x#) `shiftR` (I# i#) = I64# (x# `iShiftRA#` i#) + (I64# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = I64# (x# `iShiftRA#` i#) + | otherwise = overflowError (I64# x#) `unsafeShiftR` (I# i#) = I64# (x# `uncheckedIShiftRA#` i#) (I64# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 5ea827e2c8a5a1ef051826e7d74e48e9e440cde0..d19a31dfb27b41759b7152ea432238fe084d4fa4 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -177,10 +177,14 @@ instance Bits Word8 where (W8# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W8# (narrow8Word# (x# `shiftL#` i#)) | otherwise = W8# (x# `shiftRL#` negateInt# i#) - (W8# x#) `shiftL` (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#)) + (W8# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W8# (narrow8Word# (x# `shiftL#` i#)) + | otherwise = overflowError (W8# x#) `unsafeShiftL` (I# i#) = W8# (narrow8Word# (x# `uncheckedShiftL#` i#)) - (W8# x#) `shiftR` (I# i#) = W8# (x# `shiftRL#` i#) + (W8# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W8# (x# `shiftRL#` i#) + | otherwise = overflowError (W8# x#) `unsafeShiftR` (I# i#) = W8# (x# `uncheckedShiftRL#` i#) (W8# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W8# x# @@ -361,10 +365,14 @@ instance Bits Word16 where (W16# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W16# (narrow16Word# (x# `shiftL#` i#)) | otherwise = W16# (x# `shiftRL#` negateInt# i#) - (W16# x#) `shiftL` (I# i#) = W16# (narrow16Word# (x# `shiftL#` i#)) + (W16# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W16# (narrow16Word# (x# `shiftL#` i#)) + | otherwise = overflowError (W16# x#) `unsafeShiftL` (I# i#) = W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) - (W16# x#) `shiftR` (I# i#) = W16# (x# `shiftRL#` i#) + (W16# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W16# (x# `shiftRL#` i#) + | otherwise = overflowError (W16# x#) `unsafeShiftR` (I# i#) = W16# (x# `uncheckedShiftRL#` i#) (W16# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W16# x# @@ -591,10 +599,14 @@ instance Bits Word32 where (W32# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W32# (narrow32Word# (x# `shiftL#` i#)) | otherwise = W32# (x# `shiftRL#` negateInt# i#) - (W32# x#) `shiftL` (I# i#) = W32# (narrow32Word# (x# `shiftL#` i#)) + (W32# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W32# (narrow32Word# (x# `shiftL#` i#)) + | otherwise = overflowError (W32# x#) `unsafeShiftL` (I# i#) = W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) - (W32# x#) `shiftR` (I# i#) = W32# (x# `shiftRL#` i#) + (W32# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W32# (x# `shiftRL#` i#) + | otherwise = overflowError (W32# x#) `unsafeShiftR` (I# i#) = W32# (x# `uncheckedShiftRL#` i#) (W32# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W32# x# @@ -758,9 +770,13 @@ instance Bits Word64 where (W64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W64# (x# `shiftL64#` i#) | otherwise = W64# (x# `shiftRL64#` negateInt# i#) - (W64# x#) `shiftL` (I# i#) = W64# (x# `shiftL64#` i#) + (W64# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W64# (x# `shiftL64#` i#) + | otherwise = overflowError (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL64#` i#) - (W64# x#) `shiftR` (I# i#) = W64# (x# `shiftRL64#` i#) + (W64# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W64# (x# `shiftRL64#` i#) + | otherwise = overflowError (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL64#` i#) (W64# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W64# x# @@ -907,9 +923,13 @@ instance Bits Word64 where (W64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W64# (x# `shiftL#` i#) | otherwise = W64# (x# `shiftRL#` negateInt# i#) - (W64# x#) `shiftL` (I# i#) = W64# (x# `shiftL#` i#) + (W64# x#) `shiftL` (I# i#) + | isTrue# (i# >=# 0#) = W64# (x# `shiftL#` i#) + | otherwise = overflowError (W64# x#) `unsafeShiftL` (I# i#) = W64# (x# `uncheckedShiftL#` i#) - (W64# x#) `shiftR` (I# i#) = W64# (x# `shiftRL#` i#) + (W64# x#) `shiftR` (I# i#) + | isTrue# (i# >=# 0#) = W64# (x# `shiftRL#` i#) + | otherwise = overflowError (W64# x#) `unsafeShiftR` (I# i#) = W64# (x# `uncheckedShiftRL#` i#) (W64# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W64# x# diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 07df8fc3a3146507e21ef624f62864c478828539..3d178d3a167316e24051def964f65dd59ebda0f9 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -17,6 +17,10 @@ * Add `foldMap'`, a strict version of `foldMap`, to `Foldable`. + * The `shiftL` and `shiftR` methods in the `Bits` instances of `Int`, `IntN`, + `Word`, and `WordN` now throw an overflow exception for negative shift + values (instead of being undefined behaviour). + ## 4.12.0.0 *21 September 2018* * Bundled with GHC 8.6.1