From a820f9002d8f75385aaaa141ac3c6f001e8a9874 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Thu, 1 Jul 2021 16:55:47 +0200
Subject: [PATCH] Detect underflow in fromIntegral/Int->Natural rule
Fix #20066
---
libraries/base/GHC/Real.hs | 18 +++++++++++++++---
testsuite/tests/lib/integer/T20066.hs | 12 ++++++++++++
testsuite/tests/lib/integer/T20066.stderr | 1 +
testsuite/tests/lib/integer/all.T | 1 +
4 files changed, 29 insertions(+), 3 deletions(-)
create mode 100644 testsuite/tests/lib/integer/T20066.hs
create mode 100644 testsuite/tests/lib/integer/T20066.stderr
diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs
index df4143e1eed4..6c7ae43e5c83 100644
--- a/libraries/base/GHC/Real.hs
+++ b/libraries/base/GHC/Real.hs
@@ -597,7 +597,7 @@ fromIntegral = fromInteger . toInteger
#-}
-- Don't forget the type signatures in the following rules! Without a type
--- signature we end up with the rule:
+-- signature we ended up with the rule:
--
-- "fromIntegral/Int->Natural" forall a (d::Integral a).
-- fromIntegral @a @Natural = naturalFromWord . fromIntegral @a d
@@ -606,12 +606,24 @@ fromIntegral = fromInteger . toInteger
--
-- This rule wraps any Integral input into Word's range. As a consequence,
-- (2^64 :: Integer) was incorrectly wrapped to (0 :: Natural), see #19345.
+--
+-- A follow-up issue with this rule was that no underflow exception was raised
+-- for negative Int values (see #20066). We now use a naturalFromInt helper
+-- function to restore this behavior.
{-# RULES
-"fromIntegral/Word->Natural" fromIntegral = naturalFromWord :: Word -> Natural
-"fromIntegral/Int->Natural" fromIntegral = naturalFromWord . fromIntegral :: Int -> Natural
+"fromIntegral/Word->Natural" fromIntegral = naturalFromWord :: Word -> Natural
+"fromIntegral/Int->Natural" fromIntegral = naturalFromInt :: Int -> Natural
#-}
+-- | Convert an Int into a Natural, throwing an underflow exception for negative
+-- values.
+naturalFromInt :: Int -> Natural
+{-# INLINE naturalFromInt #-}
+naturalFromInt x
+ | x < 0 = underflowError
+ | otherwise = naturalFromWord (fromIntegral x)
+
-- | general coercion to fractional types
realToFrac :: (Real a, Fractional b) => a -> b
{-# NOINLINE [1] realToFrac #-}
diff --git a/testsuite/tests/lib/integer/T20066.hs b/testsuite/tests/lib/integer/T20066.hs
new file mode 100644
index 000000000000..9cb67a652030
--- /dev/null
+++ b/testsuite/tests/lib/integer/T20066.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -O #-}
+module Main where
+
+import Numeric.Natural
+
+i :: Int
+i = -10
+
+main :: IO ()
+main = let n :: Natural
+ n = fromIntegral i
+ in print n
diff --git a/testsuite/tests/lib/integer/T20066.stderr b/testsuite/tests/lib/integer/T20066.stderr
new file mode 100644
index 000000000000..589cc2a4a804
--- /dev/null
+++ b/testsuite/tests/lib/integer/T20066.stderr
@@ -0,0 +1 @@
+T20066: arithmetic underflow
diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T
index c6710c69a1f6..4366955e817c 100644
--- a/testsuite/tests/lib/integer/all.T
+++ b/testsuite/tests/lib/integer/all.T
@@ -32,3 +32,4 @@ test('integerImportExport', [omit_ways(['ghci'])], compile_and_run, [''])
#test('integerGmpInternals', [], compile_and_run, [''])
test('T19345', [], compile_and_run, [''])
+test('T20066', [exit_code(1)], compile_and_run, [''])
--
GitLab