[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: testsuite/T20137: Avoid impl.-defined behavior
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Apr 24 16:51:28 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
787c6e8c by Ben Gamari at 2023-04-24T12:19:06-04:00
testsuite/T20137: Avoid impl.-defined behavior
Previously we would cast pointers to uint64_t. However, implementations
are allowed to either zero- or sign-extend such casts. Instead cast to
uintptr_t to avoid this.
Fixes #23247.
- - - - -
87095f6a by Cheng Shao at 2023-04-24T12:19:44-04:00
rts: always build 64-bit atomic ops
This patch does a few things:
- Always build 64-bit atomic ops in rts/ghc-prim, even on 32-bit
platforms
- Remove legacy "64bit" cabal flag of rts package
- Fix hs_xchg64 function prototype for 32-bit platforms
- Fix AtomicFetch test for wasm32
- - - - -
2685a12d by Cheng Shao at 2023-04-24T12:20:21-04:00
compiler: don't install signal handlers when the host platform doesn't have signals
Previously, large parts of GHC API will transitively invoke
withSignalHandlers, which doesn't work on host platforms without
signal functionality at all (e.g. wasm32-wasi). By making
withSignalHandlers a no-op on those platforms, we can make more parts
of GHC API work out of the box when signals aren't supported.
- - - - -
e9a4c9cc by Cheng Shao at 2023-04-24T12:51:17-04:00
hadrian: fix non-ghc program paths passed to testsuite driver when testing cross GHC
- - - - -
b64bfeeb by Bodigrim at 2023-04-24T12:51:21-04:00
Add since pragma to Data.Functor.unzip
- - - - -
11 changed files:
- compiler/GHC/Utils/Panic.hs
- configure.ac
- hadrian/src/Rules/Generate.hs
- hadrian/src/Settings/Builders/RunTest.hs
- libraries/base/Data/Functor.hs
- libraries/ghc-prim/cbits/atomic.c
- rts/include/stg/Prim.h
- rts/rts.cabal.in
- testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
- testsuite/tests/codeGen/should_run/T20137/T20137.stdout-ws-32
- testsuite/tests/codeGen/should_run/T20137/T20137C.c
Changes:
=====================================
compiler/GHC/Utils/Panic.hs
=====================================
@@ -7,6 +7,8 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
+#include <ghcautoconf.h>
+
-- | Defines basic functions for printing error messages.
--
-- It's hard to put these functions anywhere else without causing
@@ -236,6 +238,11 @@ signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing)
-- | Temporarily install standard signal handlers for catching ^C, which just
-- throw an exception in the current thread.
withSignalHandlers :: ExceptionMonad m => m a -> m a
+#if !defined(HAVE_SIGNAL_H)
+-- No signal functionality exist on the host platform (e.g. on
+-- wasm32-wasi), so don't attempt to set up signal handlers
+withSignalHandlers = id
+#else
withSignalHandlers act = do
main_thread <- liftIO myThreadId
wtid <- liftIO (mkWeakThreadId main_thread)
@@ -295,6 +302,7 @@ withSignalHandlers act = do
mayInstallHandlers
act `MC.finally` mayUninstallHandlers
+#endif
callStackDoc :: HasCallStack => SDoc
callStackDoc = prettyCallStackDoc callStack
=====================================
configure.ac
=====================================
@@ -904,11 +904,6 @@ FP_CHECK_SIZEOF_AND_ALIGNMENT(uint64_t)
dnl for use in settings file
TargetWordSize=$ac_cv_sizeof_void_p
-if test "x$TargetWordSize" = x8; then
- AC_SUBST([Cabal64bit],[True])
-else
- AC_SUBST([Cabal64bit],[False])
-fi
AC_SUBST(TargetWordSize)
AC_C_BIGENDIAN([TargetWordBigEndian=YES],[TargetWordBigEndian=NO])
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -295,11 +295,6 @@ rtsCabalFlags = mconcat
, flag "CabalUseSystemLibFFI" UseSystemFfi
, flag "CabalLibffiAdjustors" UseLibffiForAdjustors
, flag "CabalLeadingUnderscore" LeadingUnderscore
- , interpolateVar "Cabal64bit" $ do
- let settingWord :: Setting -> Action Word
- settingWord s = read <$> setting s
- ws <- settingWord TargetWordSize
- return $ toCabalBool (ws == 8)
]
where
flag = interpolateCabalFlag
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -315,6 +315,7 @@ getTestArgs = do
bindir <- expr $ getBinaryDirectory (testCompiler args)
compiler <- expr $ getCompilerPath (testCompiler args)
globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
+ cross_prefix <- expr crossPrefix
-- the testsuite driver will itself tell us if we need to generate the docs target
-- So we always pass the haddock path if the hadrian configuration allows us to build
-- docs
@@ -354,12 +355,12 @@ getTestArgs = do
Just verbosity -> Just $ "--verbose=" ++ verbosity
wayArgs = map ("--way=" ++) (testWays args)
compilerArg = ["--config", "compiler=" ++ show (compiler)]
- ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg" <.> exe)]
+ ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- (cross_prefix <> "ghc-pkg") <.> exe)]
haddockArg = if haveDocs
- then [ "--config", "haddock=" ++ show (bindir -/- "haddock" <.> exe) ]
+ then [ "--config", "haddock=" ++ show (bindir -/- (cross_prefix <> "haddock") <.> exe) ]
else [ "--config", "haddock=" ]
- hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps" <.> exe)]
- hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc" <.> exe)]
+ hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- (cross_prefix <> "hp2ps") <.> exe)]
+ hpcArg = ["--config", "hpc=" ++ show (bindir -/- (cross_prefix <> "hpc") <.> exe)]
inTreeArg = [ "-e", "config.in_tree_compiler=" ++
show (isInTreeCompiler (testCompiler args) || testHasInTreeFiles args) ]
=====================================
libraries/base/Data/Functor.hs
=====================================
@@ -161,7 +161,10 @@ infixl 4 $>
($>) :: Functor f => f a -> b -> f b
($>) = flip (<$)
-unzip :: Functor f => f (a,b) -> (f a, f b)
+-- | Generalization of @Data.List.@'Data.List.unzip'.
+--
+-- @since 4.19.0.0
+unzip :: Functor f => f (a, b) -> (f a, f b)
unzip xs = (fst <$> xs, snd <$> xs)
-- | @'void' value@ discards or ignores the result of evaluation, such
=====================================
libraries/ghc-prim/cbits/atomic.c
=====================================
@@ -33,14 +33,12 @@ hs_atomic_add32(StgWord x, StgWord val)
return __sync_fetch_and_add((volatile StgWord32 *) x, (StgWord32) val);
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_add64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_add64(StgWord x, StgWord64 val)
{
return __sync_fetch_and_add((volatile StgWord64 *) x, val);
}
-#endif
// FetchSubByteArrayOp_Int
@@ -65,14 +63,12 @@ hs_atomic_sub32(StgWord x, StgWord val)
return __sync_fetch_and_sub((volatile StgWord32 *) x, (StgWord32) val);
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_sub64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_sub64(StgWord x, StgWord64 val)
{
return __sync_fetch_and_sub((volatile StgWord64 *) x, val);
}
-#endif
// FetchAndByteArrayOp_Int
@@ -97,14 +93,12 @@ hs_atomic_and32(StgWord x, StgWord val)
return __sync_fetch_and_and((volatile StgWord32 *) x, (StgWord32) val);
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_and64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_and64(StgWord x, StgWord64 val)
{
return __sync_fetch_and_and((volatile StgWord64 *) x, val);
}
-#endif
// FetchNandByteArrayOp_Int
@@ -206,7 +200,6 @@ hs_atomic_nand32(StgWord x, StgWord val)
#endif
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_nand64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_nand64(StgWord x, StgWord64 val)
@@ -217,7 +210,6 @@ hs_atomic_nand64(StgWord x, StgWord64 val)
CAS_NAND((volatile StgWord64 *) x, val);
#endif
}
-#endif
#pragma GCC diagnostic pop
@@ -244,14 +236,12 @@ hs_atomic_or32(StgWord x, StgWord val)
return __sync_fetch_and_or((volatile StgWord32 *) x, (StgWord32) val);
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_or64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_or64(StgWord x, StgWord64 val)
{
return __sync_fetch_and_or((volatile StgWord64 *) x, val);
}
-#endif
// FetchXorByteArrayOp_Int
@@ -276,14 +266,12 @@ hs_atomic_xor32(StgWord x, StgWord val)
return __sync_fetch_and_xor((volatile StgWord32 *) x, (StgWord32) val);
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomic_xor64(StgWord x, StgWord64 val);
StgWord64
hs_atomic_xor64(StgWord x, StgWord64 val)
{
return __sync_fetch_and_xor((volatile StgWord64 *) x, val);
}
-#endif
// CasByteArrayOp_Int
@@ -338,15 +326,13 @@ hs_xchg32(StgWord x, StgWord val)
return (StgWord) __atomic_exchange_n((StgWord32 *) x, (StgWord32) val, __ATOMIC_SEQ_CST);
}
-#if WORD_SIZE_IN_BITS == 64
//GCC provides this even on 32bit, but StgWord is still 32 bits.
-extern StgWord hs_xchg64(StgWord x, StgWord val);
-StgWord
-hs_xchg64(StgWord x, StgWord val)
+extern StgWord64 hs_xchg64(StgWord x, StgWord64 val);
+StgWord64
+hs_xchg64(StgWord x, StgWord64 val)
{
- return (StgWord) __atomic_exchange_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST);
+ return (StgWord64) __atomic_exchange_n((StgWord64 *) x, (StgWord64) val, __ATOMIC_SEQ_CST);
}
-#endif
// AtomicReadByteArrayOp_Int
// Implies a full memory barrier (see compiler/GHC/Builtin/primops.txt.pp)
@@ -391,7 +377,6 @@ hs_atomicread32(StgWord x)
#endif
}
-#if WORD_SIZE_IN_BITS == 64
extern StgWord64 hs_atomicread64(StgWord x);
StgWord64
hs_atomicread64(StgWord x)
@@ -402,7 +387,6 @@ hs_atomicread64(StgWord x)
return __sync_add_and_fetch((StgWord64 *) x, 0);
#endif
}
-#endif
// AtomicWriteByteArrayOp_Int
// Implies a full memory barrier (see compiler/GHC/Builtin/primops.txt.pp)
@@ -441,7 +425,6 @@ hs_atomicwrite32(StgWord x, StgWord val)
#endif
}
-#if WORD_SIZE_IN_BITS == 64
extern void hs_atomicwrite64(StgWord x, StgWord64 val);
void
hs_atomicwrite64(StgWord x, StgWord64 val)
@@ -452,6 +435,5 @@ hs_atomicwrite64(StgWord x, StgWord64 val)
while (!__sync_bool_compare_and_swap((StgWord64 *) x, *(StgWord64 *) x, (StgWord64) val));
#endif
}
-#endif
#endif
=====================================
rts/include/stg/Prim.h
=====================================
@@ -53,7 +53,7 @@ void hs_atomicwrite64(StgWord x, StgWord64 val);
StgWord hs_xchg8(StgWord x, StgWord val);
StgWord hs_xchg16(StgWord x, StgWord val);
StgWord hs_xchg32(StgWord x, StgWord val);
-StgWord hs_xchg64(StgWord x, StgWord val);
+StgWord64 hs_xchg64(StgWord x, StgWord64 val);
/* libraries/ghc-prim/cbits/bswap.c */
StgWord16 hs_bswap16(StgWord16 x);
=====================================
rts/rts.cabal.in
=====================================
@@ -45,8 +45,6 @@ flag libdw
default: @CabalHaveLibdw@
flag libnuma
default: @CabalHaveLibNuma@
-flag 64bit
- default: @Cabal64bit@
flag leading-underscore
default: @CabalLeadingUnderscore@
flag smp
@@ -289,27 +287,6 @@ library
stg/Types.h
-- See Note [Undefined symbols in the RTS]
- if flag(64bit)
- if flag(leading-underscore)
- ld-options:
- "-Wl,-u,_hs_atomic_add64"
- "-Wl,-u,_hs_atomic_sub64"
- "-Wl,-u,_hs_atomic_and64"
- "-Wl,-u,_hs_atomic_nand64"
- "-Wl,-u,_hs_atomic_or64"
- "-Wl,-u,_hs_atomic_xor64"
- "-Wl,-u,_hs_atomicread64"
- "-Wl,-u,_hs_atomicwrite64"
- else
- ld-options:
- "-Wl,-u,hs_atomic_add64"
- "-Wl,-u,hs_atomic_sub64"
- "-Wl,-u,hs_atomic_and64"
- "-Wl,-u,hs_atomic_nand64"
- "-Wl,-u,hs_atomic_or64"
- "-Wl,-u,hs_atomic_xor64"
- "-Wl,-u,hs_atomicread64"
- "-Wl,-u,hs_atomicwrite64"
if flag(leading-underscore)
ld-options:
"-Wl,-u,_base_GHCziTopHandler_runIO_closure"
@@ -357,21 +334,27 @@ library
"-Wl,-u,_hs_atomic_add8"
"-Wl,-u,_hs_atomic_add16"
"-Wl,-u,_hs_atomic_add32"
+ "-Wl,-u,_hs_atomic_add64"
"-Wl,-u,_hs_atomic_sub8"
"-Wl,-u,_hs_atomic_sub16"
"-Wl,-u,_hs_atomic_sub32"
+ "-Wl,-u,_hs_atomic_sub64"
"-Wl,-u,_hs_atomic_and8"
"-Wl,-u,_hs_atomic_and16"
"-Wl,-u,_hs_atomic_and32"
+ "-Wl,-u,_hs_atomic_and64"
"-Wl,-u,_hs_atomic_nand8"
"-Wl,-u,_hs_atomic_nand16"
"-Wl,-u,_hs_atomic_nand32"
+ "-Wl,-u,_hs_atomic_nand64"
"-Wl,-u,_hs_atomic_or8"
"-Wl,-u,_hs_atomic_or16"
"-Wl,-u,_hs_atomic_or32"
+ "-Wl,-u,_hs_atomic_or64"
"-Wl,-u,_hs_atomic_xor8"
"-Wl,-u,_hs_atomic_xor16"
"-Wl,-u,_hs_atomic_xor32"
+ "-Wl,-u,_hs_atomic_xor64"
"-Wl,-u,_hs_cmpxchg8"
"-Wl,-u,_hs_cmpxchg16"
"-Wl,-u,_hs_cmpxchg32"
@@ -383,9 +366,11 @@ library
"-Wl,-u,_hs_atomicread8"
"-Wl,-u,_hs_atomicread16"
"-Wl,-u,_hs_atomicread32"
+ "-Wl,-u,_hs_atomicread64"
"-Wl,-u,_hs_atomicwrite8"
"-Wl,-u,_hs_atomicwrite16"
"-Wl,-u,_hs_atomicwrite32"
+ "-Wl,-u,_hs_atomicwrite64"
"-Wl,-u,_base_GHCziStackziCloneStack_StackSnapshot_closure"
if flag(find-ptr)
@@ -440,21 +425,27 @@ library
"-Wl,-u,hs_atomic_add8"
"-Wl,-u,hs_atomic_add16"
"-Wl,-u,hs_atomic_add32"
+ "-Wl,-u,hs_atomic_add64"
"-Wl,-u,hs_atomic_sub8"
"-Wl,-u,hs_atomic_sub16"
"-Wl,-u,hs_atomic_sub32"
+ "-Wl,-u,hs_atomic_sub64"
"-Wl,-u,hs_atomic_and8"
"-Wl,-u,hs_atomic_and16"
"-Wl,-u,hs_atomic_and32"
+ "-Wl,-u,hs_atomic_and64"
"-Wl,-u,hs_atomic_nand8"
"-Wl,-u,hs_atomic_nand16"
"-Wl,-u,hs_atomic_nand32"
+ "-Wl,-u,hs_atomic_nand64"
"-Wl,-u,hs_atomic_or8"
"-Wl,-u,hs_atomic_or16"
"-Wl,-u,hs_atomic_or32"
+ "-Wl,-u,hs_atomic_or64"
"-Wl,-u,hs_atomic_xor8"
"-Wl,-u,hs_atomic_xor16"
"-Wl,-u,hs_atomic_xor32"
+ "-Wl,-u,hs_atomic_xor64"
"-Wl,-u,hs_cmpxchg8"
"-Wl,-u,hs_cmpxchg16"
"-Wl,-u,hs_cmpxchg32"
@@ -466,9 +457,11 @@ library
"-Wl,-u,hs_atomicread8"
"-Wl,-u,hs_atomicread16"
"-Wl,-u,hs_atomicread32"
+ "-Wl,-u,hs_atomicread64"
"-Wl,-u,hs_atomicwrite8"
"-Wl,-u,hs_atomicwrite16"
"-Wl,-u,hs_atomicwrite32"
+ "-Wl,-u,hs_atomicwrite64"
"-Wl,-u,base_GHCziStackziCloneStack_StackSnapshot_closure"
if flag(find-ptr)
=====================================
testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm
=====================================
@@ -7,17 +7,17 @@ cmm_foo64 (P_ p)
{
// p points to a ByteArray header, q points to its first element
P_ q;
- q = p + SIZEOF_StgHeader + WDS(1);
+ q = p + SIZEOF_StgHeader + OFFSET_StgArrBytes_payload;
- bits64 x;
+ I64 x;
- prim %store_seqcst64(q, 42);
- (x) = prim %fetch_add64(q, 5);
- (x) = prim %fetch_sub64(q, 10);
- (x) = prim %fetch_and64(q, 120);
- (x) = prim %fetch_or64(q, 2);
- (x) = prim %fetch_xor64(q, 33);
- (x) = prim %fetch_nand64(q, 127);
+ prim %store_seqcst64(q, 42 :: I64);
+ (x) = prim %fetch_add64(q, 5 :: I64);
+ (x) = prim %fetch_sub64(q, 10 :: I64);
+ (x) = prim %fetch_and64(q, 120 :: I64);
+ (x) = prim %fetch_or64(q, 2 :: I64);
+ (x) = prim %fetch_xor64(q, 33 :: I64);
+ (x) = prim %fetch_nand64(q, 127 :: I64);
(x) = prim %load_seqcst64(q);
return (x);
}
@@ -26,9 +26,9 @@ cmm_foo32 (P_ p)
{
// p points to a ByteArray header, q points to its first element
P_ q;
- q = p + SIZEOF_StgHeader + WDS(1);
+ q = p + SIZEOF_StgHeader + OFFSET_StgArrBytes_payload;
- bits32 x;
+ I32 x;
prim %store_seqcst32(q, 42);
(x) = prim %fetch_add32(q, 5);
@@ -45,9 +45,9 @@ cmm_foo16 (P_ p)
{
// p points to a ByteArray header, q points to its first element
P_ q;
- q = p + SIZEOF_StgHeader + WDS(1);
+ q = p + SIZEOF_StgHeader + OFFSET_StgArrBytes_payload;
- bits16 x;
+ I16 x;
prim %store_seqcst16(q, 42);
(x) = prim %fetch_add16(q, 5);
@@ -64,9 +64,9 @@ cmm_foo8 (P_ p)
{
// p points to a ByteArray header, q points to its first element
P_ q;
- q = p + SIZEOF_StgHeader + WDS(1);
+ q = p + SIZEOF_StgHeader + OFFSET_StgArrBytes_payload;
- bits8 x;
+ I8 x;
prim %store_seqcst8(q, 42);
(x) = prim %fetch_add8(q, 5);
=====================================
testsuite/tests/codeGen/should_run/T20137/T20137.stdout-ws-32
=====================================
@@ -5,9 +5,9 @@
5
6
77777777
-ffffffff88888888
-ffffffff99999999
-ffffffffaaaaaaaa
-ffffffffbbbbbbbb
+88888888
+99999999
+aaaaaaaa
+bbbbbbbb
cccccccc
-ffffffffdddddddd
+dddddddd
=====================================
testsuite/tests/codeGen/should_run/T20137/T20137C.c
=====================================
@@ -16,19 +16,19 @@ runInteractiveProcess (char *const * args,
{
// N.B. We don't use %p here since the rendering of this varies across
// libc implementations
- printf("%" PRIx64 "\n", (uint64_t) args);
- printf("%" PRIx64 "\n", (uint64_t) workingDirectory);
- printf("%" PRIx64 "\n", (uint64_t) environment);
+ printf("%" PRIxPTR "\n", (uintptr_t) args);
+ printf("%" PRIxPTR "\n", (uintptr_t) workingDirectory);
+ printf("%" PRIxPTR "\n", (uintptr_t) environment);
printf("%x\n", fdStdIn);
printf("%x\n", fdStdOut);
printf("%x\n", fdStdErr);
- printf("%" PRIx64 "\n", (uint64_t) pfdStdInput);
- printf("%" PRIx64 "\n", (uint64_t) pfdStdOutput);
- printf("%" PRIx64 "\n", (uint64_t) pfdStdError);
- printf("%" PRIx64 "\n", (uint64_t) childGroup);
- printf("%" PRIx64 "\n", (uint64_t) childUser);
+ printf("%" PRIxPTR "\n", (uintptr_t) pfdStdInput);
+ printf("%" PRIxPTR "\n", (uintptr_t) pfdStdOutput);
+ printf("%" PRIxPTR "\n", (uintptr_t) pfdStdError);
+ printf("%" PRIxPTR "\n", (uintptr_t) childGroup);
+ printf("%" PRIxPTR "\n", (uintptr_t) childUser);
printf("%x\n", flags);
- printf("%" PRIx64 "\n", (uint64_t) failed_doing);
+ printf("%" PRIxPTR "\n", (uintptr_t) failed_doing);
return 0;
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d93729979787f001b74e79f489a910915bc2195...b64bfeeb2f05402cfb8e3e52e464e4e43c164801
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2d93729979787f001b74e79f489a910915bc2195...b64bfeeb2f05402cfb8e3e52e464e4e43c164801
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/20230424/2857ea2e/attachment-0001.html>
More information about the ghc-commits
mailing list