From 6ee07b494ddd0131d53ea2fd6a4bb29cd05f4dd8 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Mon, 27 Jul 2020 14:50:37 +0200
Subject: Bignum: add support for negative shifts (fix #18499)

shiftR/shiftL support negative arguments despite Haskell 2010 report
saying otherwise. We explicitly test for negative values which is bad
(it gets in the way of constant folding, etc.). Anyway, for consistency
we fix Bits instancesof Integer/Natural.
---
 libraries/base/Data/Bits.hs                      | 20 ++++++++++++++----
 testsuite/tests/numeric/should_run/T18499.hs     | 27 ++++++++++++++++++++++++
 testsuite/tests/numeric/should_run/T18499.stdout | 16 ++++++++++++++
 testsuite/tests/numeric/should_run/all.T         |  1 +
 4 files changed, 60 insertions(+), 4 deletions(-)
 create mode 100644 testsuite/tests/numeric/should_run/T18499.hs
 create mode 100644 testsuite/tests/numeric/should_run/T18499.stdout

diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs
index 5379eac571..89702105eb 100644
--- a/libraries/base/Data/Bits.hs
+++ b/libraries/base/Data/Bits.hs
@@ -537,8 +537,14 @@ instance Bits Integer where
    (.|.)      = integerOr
    xor        = integerXor
    complement = integerComplement
-   shiftR x i = integerShiftR x (fromIntegral i)
-   shiftL x i = integerShiftL x (fromIntegral i)
+   unsafeShiftR x i = integerShiftR x (fromIntegral i)
+   unsafeShiftL x i = integerShiftL x (fromIntegral i)
+   shiftR x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftR x i
+      | otherwise           = overflowError
+   shiftL x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftL x i
+      | otherwise           = overflowError
    shift x i | i >= 0    = integerShiftL x (fromIntegral i)
              | otherwise = integerShiftR x (fromIntegral (negate i))
    testBit x i = integerTestBit x (fromIntegral i)
@@ -560,8 +566,14 @@ instance Bits Natural where
    xor           = naturalXor
    complement _  = errorWithoutStackTrace
                     "Bits.complement: Natural complement undefined"
-   shiftR x i    = naturalShiftR x (fromIntegral i)
-   shiftL x i    = naturalShiftL x (fromIntegral i)
+   unsafeShiftR x i = naturalShiftR x (fromIntegral i)
+   unsafeShiftL x i = naturalShiftL x (fromIntegral i)
+   shiftR x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftR x i
+      | otherwise           = overflowError
+   shiftL x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftL x i
+      | otherwise           = overflowError
    shift x i
      | i >= 0    = naturalShiftL x (fromIntegral i)
      | otherwise = naturalShiftR x (fromIntegral (negate i))
diff --git a/testsuite/tests/numeric/should_run/T18499.hs b/testsuite/tests/numeric/should_run/T18499.hs
new file mode 100644
index 0000000000..059057015f
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18499.hs
@@ -0,0 +1,27 @@
+import Data.Bits
+import Numeric.Natural
+import GHC.Exception.Type
+import Control.Exception
+
+main :: IO ()
+main = do
+   test ((42 `shiftR` (-1)) :: Integer)
+   test ((42 `shiftL` (-1)) :: Integer)
+   test ((42 `shiftR` (-1)) :: Natural)
+   test ((42 `shiftL` (-1)) :: Natural)
+   test ((42 `shiftR` (-1)) :: Word)
+   test ((42 `shiftL` (-1)) :: Word)
+   test ((42 `shiftR` (-1)) :: Int)
+   test ((42 `shiftL` (-1)) :: Int)
+
+   test ((42 `unsafeShiftR` 2) :: Integer)
+   test ((42 `unsafeShiftL` 2) :: Integer)
+   test ((42 `unsafeShiftR` 2) :: Natural)
+   test ((42 `unsafeShiftL` 2) :: Natural)
+   test ((42 `unsafeShiftR` 2) :: Word)
+   test ((42 `unsafeShiftL` 2) :: Word)
+   test ((42 `unsafeShiftR` 2) :: Int)
+   test ((42 `unsafeShiftL` 2) :: Int)
+
+test :: Show a => a -> IO ()
+test a = print a `catch` (\Overflow -> putStrLn "Overflow!")
diff --git a/testsuite/tests/numeric/should_run/T18499.stdout b/testsuite/tests/numeric/should_run/T18499.stdout
new file mode 100644
index 0000000000..7f103dc878
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18499.stdout
@@ -0,0 +1,16 @@
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+10
+168
+10
+168
+10
+168
+10
+168
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index ce44e15729..faa4d7c992 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -70,3 +70,4 @@ test('T15301', normal, compile_and_run, ['-O2'])
 test('T497', normal, compile_and_run, ['-O'])
 test('T17303', normal, compile_and_run, [''])
 test('T18359', normal, compile_and_run, [''])
+test('T18499', normal, compile_and_run, [''])
-- 
cgit v1.2.1