[Git][ghc/ghc][master] 4 commits: Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 18 23:41:00 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fe067577 by Sylvain Henry at 2023-10-18T19:40:25-04:00
Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a".
- - - - -
cc1625b1 by Sylvain Henry at 2023-10-18T19:40:25-04:00
Bignum: fix right shift of negative BigNat with native backend
- - - - -
cbe4400d by Sylvain Henry at 2023-10-18T19:40:25-04:00
Rts: expose rtsOutOfBoundsAccess symbol
- - - - -
72c7380c by Sylvain Henry at 2023-10-18T19:40:25-04:00
Hadrian: enable `-fcheck-prim-bounds` in validate flavour
This allows T24066 to fail when the bug is present.
Otherwise the out-of-bound access isn't detected as it happens in
ghc-bignum which wasn't compiled with the bounds check.
- - - - -
10 changed files:
- hadrian/doc/flavours.md
- hadrian/src/Settings/Flavours/Validate.hs
- libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat.hs
- rts/RtsMessages.c
- rts/RtsSymbols.c
- rts/include/rts/Messages.h
- + testsuite/tests/numeric/should_run/T24066.hs
- + testsuite/tests/numeric/should_run/T24066.stdout
- testsuite/tests/numeric/should_run/all.T
Changes:
=====================================
hadrian/doc/flavours.md
=====================================
@@ -157,7 +157,7 @@ when compiling the `compiler` library, and `hsGhc` when compiling/linking the GH
<th>validate</td>
<td></td>
<td>-O0<br>-H64m</td>
- <td>-fllvm-fill-undef-with-garbage</td>
+ <td>-fllvm-fill-undef-with-garbage<br>-fcheck-prim-bounds</td>
<td></td>
<td>-O<br>-dcore-lint<br>-dno-debug-output</td>
<td>-O2<br>-DDEBUG</td>
=====================================
hadrian/src/Settings/Flavours/Validate.hs
=====================================
@@ -35,6 +35,7 @@ validateArgs = sourceArgs SourceArgs
-- See #11487
, notStage0 ? arg "-fllvm-fill-undef-with-garbage"
, notStage0 ? arg "-dno-debug-output"
+ , notStage0 ? arg "-fcheck-prim-bounds"
]
, hsLibrary = pure ["-O"]
, hsCompiler = mconcat [ stage0 ? pure ["-O2"]
=====================================
libraries/ghc-bignum/src/GHC/Num/Backend/Native.hs
=====================================
@@ -295,15 +295,15 @@ bignat_shiftr_neg
-> State# s
-> State# s
bignat_shiftr_neg mwa wa n s1
- -- initialize higher limb
- = case mwaWrite# mwa (szA -# 1#) 0## s1 of
- s2 -> case bignat_shiftr mwa wa n s2 of
- s3 -> if nz_shifted_out
- -- round if non-zero bits were shifted out
- then mwaAddInplaceWord# mwa 0# 1## s3
- else s3
+ -- initialize higher limb of mwa
+ = case mwaSize# mwa s1 of
+ (# s2, sz_mwa #) -> case mwaWrite# mwa (sz_mwa -# 1#) 0## s2 of
+ s3 -> case bignat_shiftr mwa wa n s3 of
+ s4 -> if nz_shifted_out
+ -- round if non-zero bits were shifted out
+ then mwaAddInplaceWord# mwa 0# 1## s4
+ else s4
where
- !szA = wordArraySize# wa
!(# nw, nb #) = count_words_bits_int n
-- non-zero bits are shifted out?
=====================================
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#
=====================================
rts/RtsMessages.c
=====================================
@@ -326,27 +326,18 @@ rtsDebugMsgFn(const char *s, va_list ap)
}
-// Used in stg_badAlignment_entry defined in StgStartup.cmm.
-void rtsBadAlignmentBarf(void) STG_NORETURN;
-
void
rtsBadAlignmentBarf(void)
{
barf("Encountered incorrectly aligned pointer. This can't be good.");
}
-// Used by code generator
-void rtsOutOfBoundsAccess(void) STG_NORETURN;
-
void
rtsOutOfBoundsAccess(void)
{
barf("Encountered out of bounds array access.");
}
-// Used by code generator
-void rtsMemcpyRangeOverlap(void) STG_NORETURN;
-
void
rtsMemcpyRangeOverlap(void)
{
=====================================
rts/RtsSymbols.c
=====================================
@@ -947,6 +947,9 @@ extern char **environ;
SymI_HasProto(arenaFree) \
SymI_HasProto(rts_clearMemory) \
SymI_HasProto(setKeepCAFs) \
+ SymI_HasProto(rtsBadAlignmentBarf) \
+ SymI_HasProto(rtsOutOfBoundsAccess) \
+ SymI_HasProto(rtsMemcpyRangeOverlap) \
RTS_USER_SIGNALS_SYMBOLS \
RTS_INTCHAR_SYMBOLS
=====================================
rts/include/rts/Messages.h
=====================================
@@ -78,7 +78,6 @@ void debugBelch(const char *s, ...)
int vdebugBelch(const char *s, va_list ap);
-
/* Hooks for redirecting message generation: */
typedef void RtsMsgFunction(const char *, va_list);
@@ -94,3 +93,8 @@ extern RtsMsgFunction rtsFatalInternalErrorFn;
extern RtsMsgFunctionRetLen rtsDebugMsgFn;
extern RtsMsgFunction rtsErrorMsgFn;
extern RtsMsgFunction rtsSysErrorMsgFn;
+
+/* Used by code generator */
+void rtsBadAlignmentBarf(void) STG_NORETURN;
+void rtsOutOfBoundsAccess(void) STG_NORETURN;
+void rtsMemcpyRangeOverlap(void) STG_NORETURN;
=====================================
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)
=====================================
testsuite/tests/numeric/should_run/T24066.stdout
=====================================
@@ -0,0 +1 @@
+Zero isn't a power of two
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13d3c613c3c1e4942c698449bdf58a6a13b76695...72c7380cb780933825bc84924908e01ce0495dc4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13d3c613c3c1e4942c698449bdf58a6a13b76695...72c7380cb780933825bc84924908e01ce0495dc4
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/20231018/af8d90b1/attachment-0001.html>
More information about the ghc-commits
mailing list