[Git][ghc/ghc][master] Bignum: add support for negative shifts (fix #18499)

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
6ee07b49 by Sylvain Henry at 2020-07-28T02:02:27-04:00
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.

- - - - -


4 changed files:

- libraries/base/Data/Bits.hs
- + testsuite/tests/numeric/should_run/T18499.hs
- + testsuite/tests/numeric/should_run/T18499.stdout
- testsuite/tests/numeric/should_run/all.T


Changes:

=====================================
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))


=====================================
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!")


=====================================
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


=====================================
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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ee07b494ddd0131d53ea2fd6a4bb29cd05f4dd8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ee07b494ddd0131d53ea2fd6a4bb29cd05f4dd8
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200728/2bfb5c0e/attachment-0001.html>