From fe0675770b66a9ed393884d96e276b8d116fa2a2 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Fri, 6 Oct 2023 14:01:52 +0200
Subject: [PATCH] Avoid out-of-bound array access in bigNatIsPowerOf2 (fix
#24066)
bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a".
---
libraries/ghc-bignum/src/GHC/Num/BigNat.hs | 15 ++++++++-------
testsuite/tests/numeric/should_run/T24066.hs | 16 ++++++++++++++++
testsuite/tests/numeric/should_run/T24066.stdout | 1 +
testsuite/tests/numeric/should_run/all.T | 1 +
4 files changed, 26 insertions(+), 7 deletions(-)
create mode 100644 testsuite/tests/numeric/should_run/T24066.hs
create mode 100644 testsuite/tests/numeric/should_run/T24066.stdout
diff --git a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
index 21b07cb8300..c7f8afa0275 100644
--- a/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/BigNat.hs
@@ -135,13 +135,8 @@ bigNatIsTwo# ba =
bigNatIsPowerOf2# :: BigNat# -> (# (# #) | Word# #)
bigNatIsPowerOf2# a
| bigNatIsZero a = (# (# #) | #)
- | True = case wordIsPowerOf2# msw of
- (# (# #) | #) -> (# (# #) | #)
- (# | c #) -> case checkAllZeroes (imax -# 1#) of
- 0# -> (# (# #) | #)
- _ -> (# | c `plusWord#`
- (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #)
- where
+ | True =
+ let
msw = bigNatIndex# a imax
sz = bigNatSize# a
imax = sz -# 1#
@@ -150,6 +145,12 @@ bigNatIsPowerOf2# a
| True = case bigNatIndex# a i of
0## -> checkAllZeroes (i -# 1#)
_ -> 0#
+ in case wordIsPowerOf2# msw of
+ (# (# #) | #) -> (# (# #) | #)
+ (# | c #) -> case checkAllZeroes (imax -# 1#) of
+ 0# -> (# (# #) | #)
+ _ -> (# | c `plusWord#`
+ (int2Word# imax `uncheckedShiftL#` WORD_SIZE_BITS_SHIFT#) #)
-- | Return the Word# at the given index
bigNatIndex# :: BigNat# -> Int# -> Word#
diff --git a/testsuite/tests/numeric/should_run/T24066.hs b/testsuite/tests/numeric/should_run/T24066.hs
new file mode 100644
index 00000000000..dc173154bab
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T24066.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Num.BigNat
+import GHC.Exts
+
+-- just to ensure that (future) rewrite rules don't mess with the test
+{-# NOINLINE foo #-}
+foo (# #) = bigNatZero# (# #)
+
+main = do
+ case bigNatIsPowerOf2# (foo (# #)) of
+ (# _ | #) -> putStrLn "Zero isn't a power of two"
+ (# | w #) -> putStrLn $ "Zero is 2^" ++ show (W# w)
diff --git a/testsuite/tests/numeric/should_run/T24066.stdout b/testsuite/tests/numeric/should_run/T24066.stdout
new file mode 100644
index 00000000000..73aeea9203d
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T24066.stdout
@@ -0,0 +1 @@
+Zero isn't a power of two
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 26bb1fe2c62..074155bb6ec 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -81,3 +81,4 @@ test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', normal, compile_and_run, [''])
test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers'])
+test('T24066', normal, compile_and_run, [''])
--
GitLab