Error out of invalid Int/Word bit shifts

Although the Haddock's for `shiftL` and `shiftR` do require the number
of bits to be non-negative, we should still check this before calling
out to primitives (which also have undefined behaviour for negative bit
shifts).

If a user _really_ wants to bypass checks that the number of bits is
sensible, they already have the aptly-named `unsafeShiftL`/`unsafeShiftR`
at their disposal.

See #16111.

5 files changed, 82 insertions, 29 deletions

diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index f8b8f91bcc..7111c7b07a 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 4226f8e967..000e663b83 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 d74b9e211c..2c5ca9d5a8 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 5ea827e2c8..d19a31dfb2 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 07df8fc3a3..3d178d3a16 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