[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Oct 18 20:10:48 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
e2dcb855 by Sylvain Henry at 2023-10-18T16:10:04-04:00
Avoid out-of-bound array access in bigNatIsPowerOf2 (fix #24066)
bigNatIndex# in the `where` clause wasn't guarded by "bigNatIsZero a".
- - - - -
a2256b7f by Sylvain Henry at 2023-10-18T16:10:04-04:00
Bignum: fix right shift of negative BigNat with native backend
- - - - -
7fe08dee by Sylvain Henry at 2023-10-18T16:10:04-04:00
Rts: expose rtsOutOfBoundsAccess symbol
- - - - -
b5d5fb24 by Sylvain Henry at 2023-10-18T16:10:04-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.
- - - - -
3d6a03e4 by John Ericson at 2023-10-18T16:10:05-04:00
Make Hadrian solely responsible for substituting `docs/users_guide/ghc_config.py.in`
Fixes #24091
Progress on #23966
Issue #24091 reports that `@ProjectVersion@` is no longer being
substituted in the GHC user's guide. I assume this is a recent issue,
but I am not sure how it's worked since
c1a3ecde720b3bddc2c8616daaa06ee324e602ab; it looks like both Hadrian and
configure are trying to substitute the same `.in` file!
Now only Hadrian does. That is better anyways; already something that
issue #23966 requested.
It seems like we were missing some dependencies in Hadrian. (I really,
really hate that this is possible!) Hopefully it is fixed now.
- - - - -
7df22c01 by John Ericson at 2023-10-18T16:10:05-04:00
`ghcversion.h`: No need to cope with undefined `ProjectPatchLevel*`
Since 4e6c80197f1cc46dfdef0300de46847c7cfbdcb0, these are guaranteed to
be defined. (Guaranteed including a test in the testsuite.)
- - - - -
6771670d by John Ericson at 2023-10-18T16:10:05-04:00
Generate `ghcversion.h` from a `.in` file
Now that there are no conditional sections (see the previous commit), we
can just a do simple substitution rather than pasting it together line
by line.
Progress on #23966
- - - - -
18 changed files:
- configure.ac
- hadrian/cfg/system.config.in
- hadrian/doc/flavours.md
- hadrian/src/Oracles/Setting.hs
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/Cabal.hs
- 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/ghcversion.h.top
- rts/ghcversion.h.bottom → rts/include/ghcversion.h.in
- 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:
=====================================
configure.ac
=====================================
@@ -68,23 +68,6 @@ FP_PROG_SORT
dnl ----------------------------------------------------------
FP_SETUP_PROJECT_VERSION
-dnl Don't use AC_DEFINE because it will make C-style comments invalid for
-dnl Haskell.
-
-> rts/include/ghcversion.h
-
-cat rts/ghcversion.h.top >> rts/include/ghcversion.h
-
-echo "#define __GLASGOW_HASKELL__ ${ProjectVersionInt}" >> rts/include/ghcversion.h
-echo "#define __GLASGOW_HASKELL_FULL_VERSION__ \"${ProjectVersion}\"" >> rts/include/ghcversion.h
-echo >> rts/include/ghcversion.h
-AS_IF([test x"${ProjectPatchLevel1}" != x],
- [echo "#define __GLASGOW_HASKELL_PATCHLEVEL1__ ${ProjectPatchLevel1}" >> rts/include/ghcversion.h])
-AS_IF([test x"${ProjectPatchLevel2}" != x],
- [echo "#define __GLASGOW_HASKELL_PATCHLEVEL2__ ${ProjectPatchLevel2}" >> rts/include/ghcversion.h])
-
-cat rts/ghcversion.h.bottom >> rts/include/ghcversion.h
-
# Hmmm, we fix the RPM release number to 1 here... Is this convenient?
AC_SUBST([release], [1])
@@ -105,8 +88,6 @@ AC_PREREQ([2.69])
AC_CONFIG_HEADER(mk/config.h)
# This one is manually maintained.
AC_CONFIG_HEADER(compiler/ghc-llvm-version.h)
-dnl manually outputted above, for reasons described there.
-dnl AC_CONFIG_HEADER(rts/include/ghcversion.h)
# No, semi-sadly, we don't do `--srcdir'...
if test x"$srcdir" != 'x.' ; then
@@ -1069,7 +1050,6 @@ AC_CONFIG_FILES(
hadrian/ghci-cabal
hadrian/ghci-multi-cabal
hadrian/ghci-stack
- docs/users_guide/ghc_config.py
distrib/configure.ac
hadrian/cfg/default.host.target
hadrian/cfg/default.target
=====================================
hadrian/cfg/system.config.in
=====================================
@@ -34,6 +34,9 @@ python = @PythonCmd@
cc-llvm-backend = @CcLlvmBackend@
+llvm-min-version = @LlvmMinVersion@
+llvm-max-version = @LlvmMaxVersion@
+
# Build options:
#===============
=====================================
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/Oracles/Setting.hs
=====================================
@@ -49,6 +49,8 @@ data Setting = CursesIncludeDir
| GhcPatchLevel
| GhcVersion
| GhcSourcePath
+ | LlvmMinVersion
+ | LlvmMaxVersion
| GmpIncludeDir
| GmpLibDir
| IconvIncludeDir
@@ -103,6 +105,8 @@ setting key = lookupSystemConfig $ case key of
GhcPatchLevel -> "ghc-patch-level"
GhcVersion -> "ghc-version"
GhcSourcePath -> "ghc-source-path"
+ LlvmMinVersion -> "llvm-min-version"
+ LlvmMaxVersion -> "llvm-max-version"
GmpIncludeDir -> "gmp-include-dir"
GmpLibDir -> "gmp-lib-dir"
IconvIncludeDir -> "iconv-include-dir"
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -356,6 +356,9 @@ buildSphinxInfoGuide = do
root <- buildRootRules
let path = "GHCUsersGuide"
root -/- infoRoot -/- path <.> "info" %> \ file -> do
+
+ needDocDeps
+
withTempDir $ \dir -> do
let rstFilesDir = pathPath path
rstFiles <- getDirectoryFiles rstFilesDir ["**/*.rst"]
@@ -391,6 +394,8 @@ buildManPage = do
root <- buildRootRules
root -/- manPageBuildPath %> \file -> do
need ["docs/users_guide/ghc.rst"]
+ needDocDeps
+
withTempDir $ \dir -> do
build $ target docContext (Sphinx ManMode) ["docs/users_guide"] [dir]
checkSphinxWarnings dir
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -323,8 +323,19 @@ templateRules = do
templateRule "utils/ghc-pkg/ghc-pkg.cabal" $ projectVersion
templateRule "libraries/template-haskell/template-haskell.cabal" $ projectVersion
templateRule "libraries/prologue.txt" $ packageVersions
+ templateRule "rts/include/ghcversion.h" $ mconcat
+ [ interpolateSetting "ProjectVersionInt" ProjectVersionInt
+ , interpolateSetting "ProjectVersion" ProjectVersion
+ , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1
+ , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2
+ ]
templateRule "docs/index.html" $ packageVersions
- templateRule "docs/users_guide/ghc_config.py" $ packageUnitIds Stage1
+ templateRule "docs/users_guide/ghc_config.py" $ mconcat
+ [ projectVersion
+ , packageUnitIds Stage1
+ , interpolateSetting "LlvmMinVersion" LlvmMinVersion
+ , interpolateSetting "LlvmMaxVersion" LlvmMaxVersion
+ ]
-- Generators
=====================================
hadrian/src/Settings/Builders/Cabal.hs
=====================================
@@ -166,9 +166,14 @@ configureStageArgs = do
let cFlags = getStagedCCFlags
linkFlags = prgFlags . ccLinkProgram . tgtCCompilerLink <$> getStagedTarget
mconcat [ configureArgs cFlags linkFlags
- , notStage0 ? arg "--ghc-option=-ghcversion-file=rts/include/ghcversion.h"
+ , ghcVersionH
]
+ghcVersionH :: Args
+ghcVersionH = notStage0 ? do
+ let h = "rts/include/ghcversion.h"
+ expr $ need [h]
+ arg $ "--ghc-option=-ghcversion-file=" <> h
configureArgs :: Args -> Args -> Args
configureArgs cFlags' ldFlags' = do
@@ -199,7 +204,7 @@ configureArgs cFlags' ldFlags' = do
-- ROMES:TODO: how is the Host set to TargetPlatformFull? That would be the target
, conf "--host" $ arg =<< getSetting TargetPlatformFull
, conf "--with-cc" $ arg =<< getBuilderPath . (Cc CompileC) =<< getStage
- , notStage0 ? arg "--ghc-option=-ghcversion-file=rts/include/ghcversion.h"
+ , ghcVersionH
]
bootPackageConstraints :: Args
=====================================
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/ghcversion.h.top deleted
=====================================
@@ -1,3 +0,0 @@
-#if !defined(__GHCVERSION_H__)
-#define __GHCVERSION_H__
-
=====================================
rts/ghcversion.h.bottom → rts/include/ghcversion.h.in
=====================================
@@ -1,3 +1,11 @@
+#if !defined(__GHCVERSION_H__)
+#define __GHCVERSION_H__
+
+#define __GLASGOW_HASKELL__ @ProjectVersionInt@
+#define __GLASGOW_HASKELL_FULL_VERSION__ "@ProjectVersion@"
+
+#define __GLASGOW_HASKELL_PATCHLEVEL1__ @ProjectPatchLevel1@
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ @ProjectPatchLevel2@
#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) ( \
((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
=====================================
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/e1dd16d2e0458a3bbe79633595d876e929938cf1...6771670d48ff88910c53eea6c38dda469c672c9a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e1dd16d2e0458a3bbe79633595d876e929938cf1...6771670d48ff88910c53eea6c38dda469c672c9a
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/246f27d6/attachment-0001.html>
More information about the ghc-commits
mailing list