- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/rts-no-gnuc
by Cheng Shao (＠TerrorJack) 20 Sep '25

20 Sep '25

Cheng Shao pushed new branch wip/rts-no-gnuc at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/rts-no-gnuc You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 14 commits: StgToByteCode: Don't assume that data con workers are nullary
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d1d9e39e by Ben Gamari at 2025-09-19T18:24:52-04:00 StgToByteCode: Don't assume that data con workers are nullary Previously StgToByteCode assumed that all data-con workers were of a nullary representation. This is not a valid assumption, as seen in #23210, where an unsaturated application of a unary data constructor's worker resulted in invalid bytecode. Sadly, I have not yet been able to reduce a minimal testcase for this. Fixes #23210. - - - - - 3eeecd50 by Ben Gamari at 2025-09-19T18:24:53-04:00 testsuite: Mark T23146* as unbroken - - - - - 2e73f342 by sheaf at 2025-09-19T18:24:53-04:00 Add test for #26216 - - - - - c2efb912 by Sven Tennie at 2025-09-19T18:25:36-04:00 Generate correct test header This increases convenience when copying & pasting... - - - - - d2fb811e by Sven Tennie at 2025-09-19T18:25:36-04:00 foundation test: Fix shift amount (#26248) Shift primops' results are only defined for shift amounts of 0 to word size - 1. The approach is similar to testing div-like operations (which have a constraint regarding zero operands.) This was partly vibe coded (https://github.com/supersven/ghc/pull/1) but then heavily refactored. - - - - - a62ce115 by Andreas Klebinger at 2025-09-19T18:26:18-04:00 Tweak jspace test I've given it a longer timeout, and tweaked the test file generation to speed it up a bit. Hopefully that is enough to make it constentily pass. Last but not least it now also always uses three threads. - - - - - 0f034942 by Cheng Shao at 2025-09-19T18:26:59-04:00 rts: remove obsolete CC_SUPPORTS_TLS logic This patch removes obsolete CC_SUPPORTS_TLS logic throughout the rts, given __thread is now uniformly supported by C toolchains of all platforms we currently support. - - - - - ef705655 by Cheng Shao at 2025-09-19T18:27:41-04:00 rts: remove obsolete HAS_VISIBILITY_HIDDEN logic This patch removes obsolete HAS_VISIBILITY_HIDDEN logic throughout the rts, given __attribute__((visibility("hidden"))) is uniformly supported by C toolchains of all platforms we currently support. - - - - - 9fdc1f7d by Cheng Shao at 2025-09-19T18:28:21-04:00 rts: remove -O3 pragma hack in Hash.c This patch removes an obsolete gcc pragma to specify -O3 in Hash.c. Hadrian already passes the right flag. - - - - - b8cfa8f7 by Cheng Shao at 2025-09-19T18:29:01-04:00 rts: remove obsolete COMPILING_WINDOWS_DLL logic This patch removes obsolete COMPILING_WINDOWS_DLL logic throughout the rts. They were once used for compiling to win32 DLLs, but we haven't been able to compile Haskell units to win32 DLLs for many years now, due to PE format's restriction of no more than 65536 exported symbols in a single DLL. - - - - - bb760611 by Cheng Shao at 2025-09-19T18:29:42-04:00 wasm: bump browser_wasi_shim to 0.4.2 This patch bumps the browser_wasi_shim dependency of wasm dyld script to 0.4.2. - - - - - b3a1a0ab by Cheng Shao at 2025-09-19T19:02:29-04:00 compiler: move Binary instance of Map to GHC.Utils.Binary This patch moves `Binary` instance of `Map` from `haddock-api` to `GHC.Utils.Binary`. This also allows us to remove a redundant instance defined for `NameEntityInfo`, which is a type synonym for `Map`. - - - - - c77d889a by Vladislav Zavialov at 2025-09-19T19:02:30-04:00 Fix keyword in ExplicitNamespaces error message (#26418) Consider this module header and the resulting error: {-# LANGUAGE NoExplicitNamespaces #-} module T26418 (data HeadC) where -- error: [GHC-47007] -- Illegal keyword 'type' Previously, the error message would mention 'type' (as shown above), even though the user wrote 'data'. This has now been fixed. The error location has also been corrected: it is now reported at the keyword position rather than at the position of the associated import/export item. - - - - - 88f159e2 by Cheng Shao at 2025-09-19T19:02:31-04:00 wasm: fix dyld handling for forward declared GOT.func items This patch fixes wasm shared linker's handling of forward declared GOT.func items, see linked issue for details. Also adds T26430 test to witness the fix. Fixes #26430. Co-authored-by: Codex <codex(a)openai.com> - - - - - 55 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Utils/Binary.hs - − m4/fp_visibility_hidden.m4 - rts/BeginPrivate.h - rts/EndPrivate.h - rts/Hash.c - rts/Interpreter.c - − rts/RtsDllMain.c - − rts/RtsDllMain.h - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/Task.c - rts/Task.h - rts/configure.ac - rts/include/Rts.h - rts/include/RtsAPI.h - rts/include/rts/OSThreads.h - rts/include/stg/DLL.h - rts/posix/OSThreads.c - rts/rts.cabal - rts/sm/Evac.c - rts/sm/GCTDecl.h - rts/sm/GCThread.h - rts/sm/Storage.c - rts/win32/OSThreads.c - + testsuite/tests/bytecode/T26216.hs - + testsuite/tests/bytecode/T26216.script - + testsuite/tests/bytecode/T26216.stdout - + testsuite/tests/bytecode/T26216_aux.hs - testsuite/tests/bytecode/all.T - testsuite/tests/codeGen/should_run/T23146/all.T - testsuite/tests/driver/j-space/Makefile - testsuite/tests/driver/j-space/all.T - testsuite/tests/driver/j-space/genJspace - + testsuite/tests/ghci-wasm/Makefile - + testsuite/tests/ghci-wasm/T26430.hs - + testsuite/tests/ghci-wasm/T26430A.c - + testsuite/tests/ghci-wasm/T26430B.c - + testsuite/tests/ghci-wasm/all.T - testsuite/tests/numeric/should_run/foundation.hs - testsuite/tests/parser/should_fail/T16270h.stderr - + testsuite/tests/parser/should_fail/T26418.hs - + testsuite/tests/parser/should_fail/T26418.stderr - testsuite/tests/parser/should_fail/all.T - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/jsffi/dyld.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/72d6dabeaed5e7764256c0bd98e11f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/72d6dabeaed5e7764256c0bd98e11f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] wasm: bump browser_wasi_shim to 0.4.2
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: bb760611 by Cheng Shao at 2025-09-19T18:29:42-04:00 wasm: bump browser_wasi_shim to 0.4.2 This patch bumps the browser_wasi_shim dependency of wasm dyld script to 0.4.2. - - - - - 1 changed file: - utils/jsffi/dyld.mjs Changes: ===================================== utils/jsffi/dyld.mjs ===================================== @@ -308,7 +308,7 @@ if (isNode) { } catch {} } else { wasi = await import( - "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.4.1/dist/index.js" + "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.4.2/dist/index.js" ); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb760611630402a1349b1952e345d87… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bb760611630402a1349b1952e345d87… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: remove obsolete COMPILING_WINDOWS_DLL logic
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b8cfa8f7 by Cheng Shao at 2025-09-19T18:29:01-04:00 rts: remove obsolete COMPILING_WINDOWS_DLL logic This patch removes obsolete COMPILING_WINDOWS_DLL logic throughout the rts. They were once used for compiling to win32 DLLs, but we haven't been able to compile Haskell units to win32 DLLs for many years now, due to PE format's restriction of no more than 65536 exported symbols in a single DLL. - - - - - 8 changed files: - − rts/RtsDllMain.c - − rts/RtsDllMain.h - rts/RtsSymbols.c - rts/StgMiscClosures.cmm - rts/include/RtsAPI.h - rts/include/stg/DLL.h - rts/rts.cabal - rts/sm/Evac.c Changes: ===================================== rts/RtsDllMain.c deleted ===================================== @@ -1,43 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team 1999-2000 - * - * Entry point for RTS-in-a-DLL - * - * ---------------------------------------------------------------------------*/ - -#include "rts/PosixSource.h" -#include "Rts.h" -#include "RtsAPI.h" -#include "RtsDllMain.h" - -#if defined(HAVE_WINDOWS_H) -#include <windows.h> -#endif - -/* I'd be mildly surprised if this wasn't defined, but still. */ -#if defined(COMPILING_WINDOWS_DLL) -BOOL -WINAPI -DllMain ( HINSTANCE hInstance STG_UNUSED - , DWORD reason - , LPVOID reserved STG_UNUSED - ) -{ - /* - * Note: the DllMain() doesn't call startupHaskell() for you, - * that is the task of users of the RTS. The reason is - * that *you* want to be able to control the arguments - * you pass to the RTS. - */ - switch (reason) { - - // shutdownHaskelAndExit() is already being called, - // so I don't think we need this. BL 2009/11/17 - - //case DLL_PROCESS_DETACH: shutdownHaskell(); - } - return true; -} - -#endif ===================================== rts/RtsDllMain.h deleted ===================================== @@ -1,15 +0,0 @@ -#include "Rts.h" - -#if defined(HAVE_WINDOWS_H) -#include <windows.h> -#endif - -/* I'd be mildly surprised if this wasn't defined, but still. */ -#if defined(COMPILING_WINDOWS_DLL) -BOOL -WINAPI -DllMain ( HINSTANCE hInstance - , DWORD reason - , LPVOID reserved - ); -#endif ===================================== rts/RtsSymbols.c ===================================== @@ -435,17 +435,9 @@ extern char **environ; // On most platforms, the garbage collector rewrites references // to small integer and char objects to a set of common, shared ones. -// -// We don't do this when compiling to Windows DLLs at the moment because -// it doesn't support cross package data references well. -// -#if defined(COMPILING_WINDOWS_DLL) -#define RTS_INTCHAR_SYMBOLS -#else #define RTS_INTCHAR_SYMBOLS \ SymI_HasProto(stg_CHARLIKE_closure) \ SymI_HasProto(stg_INTLIKE_closure) -#endif #if defined(PROFILING) #define RTS_PROF_SYMBOLS \ @@ -1027,20 +1019,9 @@ extern char **environ; /* entirely bogus claims about types of these symbols */ #define SymI_NeedsProto(vvv) extern void vvv(void); #define SymI_NeedsDataProto(vvv) extern StgWord vvv[]; -#if defined(COMPILING_WINDOWS_DLL) -#define SymE_HasProto(vvv) SymE_HasProto(vvv); -# if defined(x86_64_HOST_ARCH) -# define SymE_NeedsProto(vvv) extern void __imp_ ## vvv (void); -# define SymE_NeedsDataProto(vvv) SymE_NeedsProto(vvv) -# else -# define SymE_NeedsProto(vvv) extern void _imp__ ## vvv (void); -# define SymE_NeedsDataProto(vvv) SymE_NeedsProto(vvv) -# endif -#else #define SymE_NeedsProto(vvv) SymI_NeedsProto(vvv); #define SymE_NeedsDataProto(vvv) SymI_NeedsDataProto(vvv); #define SymE_HasProto(vvv) SymI_HasProto(vvv); -#endif #define SymI_HasProto(vvv) /**/ #define SymI_HasDataProto(vvv) /**/ #define SymI_HasProto_redirect(vvv,xxx,strength,ty) /**/ ===================================== rts/StgMiscClosures.cmm ===================================== @@ -1040,28 +1040,12 @@ CLOSURE(stg_ASYNCIO_LIVE0_closure,stg_ASYNCIO_LIVE0); replace them with references to the static objects. ------------------------------------------------------------------------- */ -#if defined(COMPILING_WINDOWS_DLL) -/* - * When sticking the RTS in a Windows DLL, we delay populating the - * Charlike and Intlike tables until load-time, which is only - * when we've got the real addresses to the C# and I# closures. - * - * -- this is currently broken BL 2009/11/14. - * we don't rewrite to static closures at all with Windows DLLs. - */ -// #warning Is this correct? _imp is a pointer! -#define Char_hash_con_info _imp__ghczminternal_GHCziInternalziTypes_Czh_con_info -#define Int_hash_con_info _imp__ghczminternal_GHCziInternalziTypes_Izh_con_info -#else #define Char_hash_con_info ghczminternal_GHCziInternalziTypes_Czh_con_info #define Int_hash_con_info ghczminternal_GHCziInternalziTypes_Izh_con_info -#endif - #define CHARLIKE_HDR(n) CLOSURE(Char_hash_con_info, n) #define INTLIKE_HDR(n) CLOSURE(Int_hash_con_info, n) -#if !(defined(COMPILING_WINDOWS_DLL)) section "data" { stg_CHARLIKE_closure: CHARLIKE_HDR(0) @@ -1598,5 +1582,3 @@ section "data" { INTLIKE_HDR(255) /* MAX_INTLIKE == 255 See #16961 for why 255 */ } - -#endif ===================================== rts/include/RtsAPI.h ===================================== @@ -581,19 +581,11 @@ void rts_done (void); These are used by foreign export and foreign import "wrapper" stubs. ----------------------------------------------------------------------- */ -// When producing Windows DLLs the we need to know which symbols are in the -// local package/DLL vs external ones. -// // Note that RtsAPI.h is also included by foreign export stubs in // the base package itself. // -#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_GHC_INTERNAL_PACKAGE) -__declspec(dllimport) extern StgClosure ghczminternal_GHCziInternalziTopHandler_runIO_closure; -__declspec(dllimport) extern StgClosure ghczminternal_GHCziInternalziTopHandler_runNonIO_closure; -#else extern StgClosure ghczminternal_GHCziInternalziTopHandler_runIO_closure; extern StgClosure ghczminternal_GHCziInternalziTopHandler_runNonIO_closure; -#endif #define runIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runIO_closure) #define runNonIO_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runNonIO_closure) ===================================== rts/include/stg/DLL.h ===================================== @@ -13,29 +13,9 @@ #pragma once -#if defined(COMPILING_WINDOWS_DLL) -# if defined(x86_64_HOST_ARCH) -# define DLL_IMPORT_DATA_REF(x) (__imp_##x) -# define DLL_IMPORT_DATA_VARNAME(x) *__imp_##x -# else -# define DLL_IMPORT_DATA_REF(x) (_imp__##x) -# define DLL_IMPORT_DATA_VARNAME(x) *_imp__##x -# endif -# if __GNUC__ && !defined(__declspec) -# define DLLIMPORT -# else -# define DLLIMPORT __declspec(dllimport) -# if defined(x86_64_HOST_ARCH) -# define DLLIMPORT_DATA(x) __imp_##x -# else -# define DLLIMPORT_DATA(x) _imp__##x -# endif -# endif -#else # define DLL_IMPORT_DATA_REF(x) (&(x)) # define DLL_IMPORT_DATA_VARNAME(x) x # define DLLIMPORT -#endif /* The view of the rts/include/ header files differ ever so slightly depending on whether the RTS is being compiled @@ -47,26 +27,9 @@ using Win32 DLLs. ] */ #if defined(COMPILING_RTS) -#define DLL_IMPORT DLLIMPORT #define DLL_IMPORT_RTS #define DLL_IMPORT_DATA_VAR(x) x #else -#define DLL_IMPORT #define DLL_IMPORT_RTS DLLIMPORT -# if defined(COMPILING_WINDOWS_DLL) -# if defined(x86_64_HOST_ARCH) -# define DLL_IMPORT_DATA_VAR(x) __imp_##x -# else -# define DLL_IMPORT_DATA_VAR(x) _imp__##x -# endif -# else -# define DLL_IMPORT_DATA_VAR(x) x -# endif -#endif - - -#if defined(COMPILING_STDLIB) -#define DLL_IMPORT_STDLIB -#else -#define DLL_IMPORT_STDLIB DLLIMPORT +#define DLL_IMPORT_DATA_VAR(x) x #endif ===================================== rts/rts.cabal ===================================== @@ -443,7 +443,6 @@ library RetainerProfile.c RetainerSet.c RtsAPI.c - RtsDllMain.c RtsFlags.c RtsMain.c RtsMessages.c ===================================== rts/sm/Evac.c ===================================== @@ -857,9 +857,6 @@ loop: // case CONSTR_0_1: { -#if defined(COMPILING_WINDOWS_DLL) - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); -#else StgWord w = (StgWord)q->payload[0]; if (info == Czh_con_info && // unsigned, so always true: (StgChar)w >= MIN_CHARLIKE && @@ -879,7 +876,6 @@ loop: else { copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); } -#endif return; } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8cfa8f741729ef123569fb321c4b2a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8cfa8f741729ef123569fb321c4b2a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: remove -O3 pragma hack in Hash.c
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 9fdc1f7d by Cheng Shao at 2025-09-19T18:28:21-04:00 rts: remove -O3 pragma hack in Hash.c This patch removes an obsolete gcc pragma to specify -O3 in Hash.c. Hadrian already passes the right flag. - - - - - 1 changed file: - rts/Hash.c Changes: ===================================== rts/Hash.c ===================================== @@ -14,18 +14,6 @@ #include "Hash.h" #include "RtsUtils.h" -/* This file needs to be compiled with vectorization enabled. Unfortunately - since we compile these things these days with cabal we can no longer - specify optimization per file. So we have to resort to pragmas. */ -#if defined(__GNUC__) || defined(__GNUG__) -#if !defined(__clang__) -#if !defined(DEBUG) -#pragma GCC push_options -#pragma GCC optimize ("O3") -#endif -#endif -#endif - #define XXH_INLINE_ALL #include "xxhash.h" @@ -570,12 +558,3 @@ int keyCountHashTable (HashTable *table) { return table->kcount; } - - -#if defined(__GNUC__) || defined(__GNUG__) -#if !defined(__clang__) -#if !defined(DEBUG) -#pragma GCC pop_options -#endif -#endif -#endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fdc1f7d855cc61f90de909875f6ae0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9fdc1f7d855cc61f90de909875f6ae0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: remove obsolete HAS_VISIBILITY_HIDDEN logic
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: ef705655 by Cheng Shao at 2025-09-19T18:27:41-04:00 rts: remove obsolete HAS_VISIBILITY_HIDDEN logic This patch removes obsolete HAS_VISIBILITY_HIDDEN logic throughout the rts, given __attribute__((visibility("hidden"))) is uniformly supported by C toolchains of all platforms we currently support. - - - - - 5 changed files: - − m4/fp_visibility_hidden.m4 - rts/BeginPrivate.h - rts/EndPrivate.h - rts/configure.ac - rts/include/Rts.h Changes: ===================================== m4/fp_visibility_hidden.m4 deleted ===================================== @@ -1,16 +0,0 @@ -# FP_VISIBILITY_HIDDEN -# ---------------------------------- -# Is the visibility hidden attribute supported? -AC_DEFUN([FP_VISIBILITY_HIDDEN], -[ - AC_MSG_CHECKING([whether __attribute__((visibility("hidden"))) is supported]) - echo '__attribute__((visibility("hidden"))) void foo(void) {}' > conftest.c - if $CC -Wall -Werror -c conftest.c > /dev/null 2>&1 - then - AC_MSG_RESULT([yes]) - AC_DEFINE(HAS_VISIBILITY_HIDDEN, 1, [Has visibility hidden]) - else - AC_MSG_RESULT([no]) - fi - rm -f conftest.c conftest.o -]) ===================================== rts/BeginPrivate.h ===================================== @@ -1,10 +1 @@ -/* We don't use symbol visibility pragmas on FreeBSD, because it causes - "undefined reference" errors at link-time. The true reasons are - unknown, however FreeBSD 8.x includes GCC 4.2.1 in the base system, - which might be buggy. */ -/* On Windows, with gcc 4.5.0-1, using visibility hidden gives: - error: visibility attribute not supported in this configuration; ignored - */ -#if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility push(hidden) -#endif ===================================== rts/EndPrivate.h ===================================== @@ -1,3 +1 @@ -#if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility pop -#endif ===================================== rts/configure.ac ===================================== @@ -204,8 +204,6 @@ if test "$CABAL_FLAG_leading_underscore" = 1; then AC_DEFINE([LEADING_UNDERSCORE], [1], [Define to 1 if C symbols have a leading underscore added by the compiler.]) fi -FP_VISIBILITY_HIDDEN - FP_MUSTTAIL dnl ** check for librt ===================================== rts/include/Rts.h ===================================== @@ -63,11 +63,7 @@ extern "C" { // Symbols that are extern, but private to the RTS, are declared // with visibility "hidden" to hide them outside the RTS shared // library. -#if defined(HAS_VISIBILITY_HIDDEN) #define RTS_PRIVATE GNUC3_ATTRIBUTE(visibility("hidden")) -#else -#define RTS_PRIVATE /* disabled: RTS_PRIVATE */ -#endif #if __GNUC__ >= 4 #define RTS_UNLIKELY(p) __builtin_expect((p),0) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef7056554df5603ec4d1e33193abe95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef7056554df5603ec4d1e33193abe95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: remove obsolete CC_SUPPORTS_TLS logic
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 0f034942 by Cheng Shao at 2025-09-19T18:26:59-04:00 rts: remove obsolete CC_SUPPORTS_TLS logic This patch removes obsolete CC_SUPPORTS_TLS logic throughout the rts, given __thread is now uniformly supported by C toolchains of all platforms we currently support. - - - - - 9 changed files: - rts/Task.c - rts/Task.h - rts/configure.ac - rts/include/rts/OSThreads.h - rts/posix/OSThreads.c - rts/sm/GCTDecl.h - rts/sm/GCThread.h - rts/sm/Storage.c - rts/win32/OSThreads.c Changes: ===================================== rts/Task.c ===================================== @@ -52,11 +52,7 @@ Mutex all_tasks_mutex; // A thread-local-storage key that we can use to get access to the // current thread's Task structure. #if defined(THREADED_RTS) -# if CC_SUPPORTS_TLS __thread Task *my_task; -# else -ThreadLocalKey currentTaskKey; -# endif #else Task *my_task; #endif @@ -75,9 +71,6 @@ initTaskManager (void) peakWorkerCount = 0; tasksInitialized = 1; #if defined(THREADED_RTS) -#if !CC_SUPPORTS_TLS - newThreadLocalKey(&currentTaskKey); -#endif initMutex(&all_tasks_mutex); #endif } @@ -109,9 +102,6 @@ freeTaskManager (void) #if defined(THREADED_RTS) closeMutex(&all_tasks_mutex); -#if !CC_SUPPORTS_TLS - freeThreadLocalKey(&currentTaskKey); -#endif #endif tasksInitialized = 0; ===================================== rts/Task.h ===================================== @@ -265,12 +265,8 @@ extern uint32_t peakWorkerCount; // A thread-local-storage key that we can use to get access to the // current thread's Task structure. #if defined(THREADED_RTS) -#if CC_SUPPORTS_TLS extern __thread Task *my_task; #else -extern ThreadLocalKey currentTaskKey; -#endif -#else extern Task *my_task; #endif @@ -283,21 +279,13 @@ extern Task *my_task; INLINE_HEADER Task * myTask (void) { -#if defined(THREADED_RTS) && !CC_SUPPORTS_TLS - return (Task*) getThreadLocalVar(&currentTaskKey); -#else return my_task; -#endif } INLINE_HEADER void setMyTask (Task *task) { -#if defined(THREADED_RTS) && !CC_SUPPORTS_TLS - setThreadLocalVar(&currentTaskKey,task); -#else my_task = task; -#endif } // Tasks are identified by their OS thread ID, which can be serialised ===================================== rts/configure.ac ===================================== @@ -234,19 +234,6 @@ AC_CHECK_FUNCS([eventfd]) AC_CHECK_FUNCS([getpid getuid raise]) -dnl ** Check for __thread support in the compiler -AC_MSG_CHECKING(for __thread support) -AC_COMPILE_IFELSE( - [ AC_LANG_SOURCE([[__thread int tester = 0;]]) ], - [ - AC_MSG_RESULT(yes) - AC_DEFINE([CC_SUPPORTS_TLS],[1],[Define to 1 if __thread is supported]) - ], - [ - AC_MSG_RESULT(no) - AC_DEFINE([CC_SUPPORTS_TLS],[0],[Define to 1 if __thread is supported]) - ]) - dnl large address space support (see rts/include/rts/storage/MBlock.h) dnl dnl Darwin has vm_allocate/vm_protect ===================================== rts/include/rts/OSThreads.h ===================================== @@ -40,7 +40,6 @@ typedef struct { } Condition; typedef pthread_mutex_t Mutex; typedef pthread_t OSThreadId; -typedef pthread_key_t ThreadLocalKey; #define OSThreadProcAttr /* nothing */ @@ -107,7 +106,6 @@ typedef CONDITION_VARIABLE Condition; typedef DWORD OSThreadId; // don't be tempted to use HANDLE as the OSThreadId: there can be // many HANDLES to a given thread, so comparison would not work. -typedef DWORD ThreadLocalKey; #define OSThreadProcAttr @@ -168,7 +166,6 @@ typedef SRWLOCK Mutex; typedef void* Condition; typedef void* Mutex; typedef void* OSThreadId; -typedef void* ThreadLocalKey; #define OSThreadProcAttr @@ -216,14 +213,6 @@ extern bool timedWaitCondition ( Condition* pCond, Mutex* pMut, Time timeout) extern void initMutex ( Mutex* pMut ); extern void closeMutex ( Mutex* pMut ); -// -// Thread-local storage -// -void newThreadLocalKey (ThreadLocalKey *key); -void *getThreadLocalVar (ThreadLocalKey *key); -void setThreadLocalVar (ThreadLocalKey *key, void *value); -void freeThreadLocalKey (ThreadLocalKey *key); - // Processors and affinity void setThreadAffinity (uint32_t n, uint32_t m); void setThreadNode (uint32_t node); ===================================== rts/posix/OSThreads.c ===================================== @@ -286,43 +286,6 @@ closeMutex(Mutex* pMut) pthread_mutex_destroy(pMut); } -void -newThreadLocalKey (ThreadLocalKey *key) -{ - int r; - if ((r = pthread_key_create(key, NULL)) != 0) { - barf("newThreadLocalKey: %s", strerror(r)); - } -} - -void * -getThreadLocalVar (ThreadLocalKey *key) -{ - return pthread_getspecific(*key); - // Note: a return value of NULL can indicate that either the key - // is not valid, or the key is valid and the data value has not - // yet been set. We need to use the latter case, so we cannot - // detect errors here. -} - -void -setThreadLocalVar (ThreadLocalKey *key, void *value) -{ - int r; - if ((r = pthread_setspecific(*key,value)) != 0) { - barf("setThreadLocalVar: %s", strerror(r)); - } -} - -void -freeThreadLocalKey (ThreadLocalKey *key) -{ - int r; - if ((r = pthread_key_delete(*key)) != 0) { - barf("freeThreadLocalKey: %s", strerror(r)); - } -} - #if defined(THREADED_RTS) static void * ===================================== rts/sm/GCTDecl.h ===================================== @@ -50,23 +50,10 @@ extern StgWord8 the_gc_thread[]; /* -------------------------------------------------------------------------- */ -/* Now, llvm-gcc and some older Clang compilers do not support - __thread. So we have to fallback to the extremely slow case, - unfortunately. - - Also, the iOS Clang compiler doesn't support __thread either for - some bizarre reason, so there's not much we can do about that... */ -#if defined(CC_LLVM_BACKEND) && (CC_SUPPORTS_TLS == 0) -#define gct ((gc_thread *)(pthread_getspecific(gctKey))) -#define SET_GCT(to) (pthread_setspecific(gctKey, to)) -#define DECLARE_GCT ThreadLocalKey gctKey; - -/* -------------------------------------------------------------------------- */ - -/* However, if we *are* using an LLVM based compiler with __thread +/* If we *are* using an LLVM based compiler with __thread support, then use that (since LLVM doesn't support global register variables.) */ -#elif defined(CC_LLVM_BACKEND) && (CC_SUPPORTS_TLS == 1) +#if defined(CC_LLVM_BACKEND) extern __thread gc_thread* gct; #define SET_GCT(to) gct = (to) #define DECLARE_GCT __thread gc_thread* gct; @@ -107,16 +94,11 @@ GCT_REG_DECL(gc_thread*, gct, REG_R1); /* Finally, as an absolute fallback, if none of the above tests check out but we *do* have __thread support, then use that. */ -#elif CC_SUPPORTS_TLS == 1 +#else extern __thread gc_thread* gct; #define SET_GCT(to) gct = (to) #define DECLARE_GCT __thread gc_thread* gct; -/* -------------------------------------------------------------------------- */ - -/* Impossible! */ -#else -#error Cannot find a way to declare the thread-local gc variable! #endif #endif // THREADED_RTS ===================================== rts/sm/GCThread.h ===================================== @@ -212,8 +212,4 @@ extern uint32_t n_gc_threads; extern gc_thread **gc_threads; -#if defined(THREADED_RTS) && defined(CC_LLVM_BACKEND) -extern ThreadLocalKey gctKey; -#endif - #include "EndPrivate.h" ===================================== rts/sm/Storage.c ===================================== @@ -326,10 +326,6 @@ void storageAddCapabilities (uint32_t from, uint32_t to) } } -#if defined(THREADED_RTS) && defined(CC_LLVM_BACKEND) && (CC_SUPPORTS_TLS == 0) - newThreadLocalKey(&gctKey); -#endif - initGcThreads(from, to); } @@ -351,9 +347,6 @@ freeStorage (bool free_heap) closeMutex(&sm_mutex); #endif stgFree(nurseries); -#if defined(THREADED_RTS) && defined(CC_LLVM_BACKEND) && (CC_SUPPORTS_TLS == 0) - freeThreadLocalKey(&gctKey); -#endif freeGcThreads(); } ===================================== rts/win32/OSThreads.c ===================================== @@ -87,56 +87,6 @@ osThreadIsAlive(OSThreadId id) return (exit_code == STILL_ACTIVE); } -void -newThreadLocalKey (ThreadLocalKey *key) -{ - DWORD r; - r = TlsAlloc(); - if (r == TLS_OUT_OF_INDEXES) { - barf("newThreadLocalKey: out of keys"); - } - *key = r; -} - -void * -getThreadLocalVar (ThreadLocalKey *key) -{ - void *r; - r = TlsGetValue(*key); -#if defined(DEBUG) - // r is allowed to be NULL - it can mean that either there was an - // error or the stored value is in fact NULL. - if (GetLastError() != NO_ERROR) { - sysErrorBelch("getThreadLocalVar"); - stg_exit(EXIT_FAILURE); - } -#endif - return r; -} - -void -setThreadLocalVar (ThreadLocalKey *key, void *value) -{ - BOOL b; - b = TlsSetValue(*key, value); - if (!b) { - sysErrorBelch("setThreadLocalVar"); - stg_exit(EXIT_FAILURE); - } -} - -void -freeThreadLocalKey (ThreadLocalKey *key) -{ - BOOL r; - r = TlsFree(*key); - if (r == 0) { - DWORD dw = GetLastError(); - barf("freeThreadLocalKey failed: %lu", dw); - } -} - - static unsigned forkOS_createThreadWrapper ( void * entry ) { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f034942724233e1457549123b46880… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0f034942724233e1457549123b46880… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Tweak jspace test
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a62ce115 by Andreas Klebinger at 2025-09-19T18:26:18-04:00 Tweak jspace test I've given it a longer timeout, and tweaked the test file generation to speed it up a bit. Hopefully that is enough to make it constentily pass. Last but not least it now also always uses three threads. - - - - - 3 changed files: - testsuite/tests/driver/j-space/Makefile - testsuite/tests/driver/j-space/all.T - testsuite/tests/driver/j-space/genJspace Changes: ===================================== testsuite/tests/driver/j-space/Makefile ===================================== @@ -5,5 +5,5 @@ include $(TOP)/mk/test.mk jspace: ./genJspace "$(TEST_HC)" $(TEST_HC_OPTS) -Wall -Werror -v0 jspace.hs -rtsopts -package ghc -threaded - ./jspace$(exeext) +RTS -N -hT --no-automatic-heap-samples -RTS "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" + ./jspace$(exeext) +RTS -N3 -qn2 -hT --no-automatic-heap-samples -RTS "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" ===================================== testsuite/tests/driver/j-space/all.T ===================================== @@ -1 +1,4 @@ -test('jspace', [extra_files(['genJspace']), req_target_smp, req_ghc_smp, js_broken(22573)], makefile_test, ['jspace']) +# For slightly unclear reasons this test sometimes performs terribly on arm. +# For the moment we simply give it a slightly higher timeout to address this. +test('jspace', [extra_files(['genJspace']), req_target_smp, req_ghc_smp, js_broken(22573) + , run_timeout_multiplier(2) ], makefile_test, ['jspace']) ===================================== testsuite/tests/driver/j-space/genJspace ===================================== @@ -9,25 +9,22 @@ DEPTH=8 WIDTH=40 echo "module JSpaceTest where" > JSpaceTest.hs echo "module W where" > W.hs - for j in $(seq -w 1 300); do - echo "w$j = 123" >> W.hs; - done + +awk -v len="10" 'BEGIN {for (i=1;i<=len;i++) print "w"i" = 123"}' >> W.hs + for i in $(seq -w 1 $WIDTH); do echo "module W$i where" > W$i.hs; echo "import W" >> W$i.hs; echo "import W$i" >> JSpaceTest.hs; - for j in $(seq -w 1 1000); do - echo "w$j = 123" >> W$i.hs; - done + awk -v len="1000" 'BEGIN {for (i=1;i<=len;i++) print "w"i" = 123"}' >> W$i.hs; done + echo "module H0 where" > H0.hs; echo "import {-# SOURCE #-} H$DEPTH" >> H0.hs; echo "import H$DEPTH" >> JSpaceTest.hs; for i in $(seq -w 1 $DEPTH); do echo "module H$i where" > H$i.hs; echo "import H$((i-1))" >> H$i.hs; - for j in $(seq -w 1 100); do - echo "h$j = 123" >> H$i.hs; - done + awk -v len="100" 'BEGIN {for (i=1;i<=len;i++) print "h"i" = 123"}' >> H$i.hs; done echo "module H$DEPTH where" > H$DEPTH.hs-boot; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a62ce115a1ff852df797e26d01927e3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a62ce115a1ff852df797e26d01927e3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Generate correct test header
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: c2efb912 by Sven Tennie at 2025-09-19T18:25:36-04:00 Generate correct test header This increases convenience when copying & pasting... - - - - - d2fb811e by Sven Tennie at 2025-09-19T18:25:36-04:00 foundation test: Fix shift amount (#26248) Shift primops' results are only defined for shift amounts of 0 to word size - 1. The approach is similar to testing div-like operations (which have a constraint regarding zero operands.) This was partly vibe coded (https://github.com/supersven/ghc/pull/1) but then heavily refactored. - - - - - 4 changed files: - compiler/GHC/Builtin/primops.txt.pp - testsuite/tests/numeric/should_run/foundation.hs - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs Changes: ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -148,6 +148,7 @@ defaults vector = [] deprecated_msg = {} -- A non-empty message indicates deprecation div_like = False -- Second argument expected to be non zero - used for tests + shift_like = False -- Second argument expected to be atmost first argument's word size -1 - used for tests defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) -- Note [When do out-of-line primops go in primops.txt.pp] @@ -312,8 +313,16 @@ primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# div_like = True primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True + primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True + primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# + with + shift_like = True primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# with code_size = 0 @@ -372,7 +381,12 @@ primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8# primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8# primop Word8SllOp "uncheckedShiftLWord8#" GenPrimOp Word8# -> Int# -> Word8# + with + shift_like = True + primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# + with + shift_like = True primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# with code_size = 0 @@ -422,8 +436,16 @@ primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, I div_like = True primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True + primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True + primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# + with + shift_like = True primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# with code_size = 0 @@ -482,7 +504,12 @@ primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16# primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16# primop Word16SllOp "uncheckedShiftLWord16#" GenPrimOp Word16# -> Int# -> Word16# + with + shift_like = True + primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16# + with + shift_like = True primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# with code_size = 0 @@ -532,8 +559,16 @@ primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, I div_like = True primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True + primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True + primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# + with + shift_like = True primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# with code_size = 0 @@ -592,7 +627,12 @@ primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32# primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# + with + shift_like = True + primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# + with + shift_like = True primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# with code_size = 0 @@ -637,8 +677,16 @@ primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# div_like = True primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True + primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True + primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# + with + shift_like = True primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# with code_size = 0 @@ -692,7 +740,12 @@ primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# + with + shift_like = True + primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# + with + shift_like = True primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# with code_size = 0 @@ -865,12 +918,20 @@ primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# {Shift left. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop IntSraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# {Shift right arithmetic. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop IntSrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# {Shift right logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True ------------------------------------------------------------------------ section "Word#" @@ -946,9 +1007,14 @@ primop WordNotOp "not#" GenPrimOp Word# -> Word# primop WordSllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# {Shift left logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True + primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# {Shift right logical. Result undefined if shift amount is not in the range 0 to word size - 1 inclusive.} + with + shift_like = True primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# with code_size = 0 ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -13,6 +13,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE MagicHash #-} @@ -24,7 +25,7 @@ module Main ( main ) where -import Data.Bits (Bits((.&.), bit)) +import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize) import Data.Word import Data.Int import GHC.Natural @@ -133,6 +134,16 @@ newtype NonZero a = NonZero { getNonZero :: a } instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where arbitrary = nonZero +-- | A newtype for shift amounts that are bounded by @wordSize - 1@ +newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int} + deriving (Eq, Ord, Show) + +instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where + arbitrary = do + x <- arbitrary + let widthBits = finiteBitSize (undefined :: a) + pure $ BoundedShiftAmount (abs x `mod` widthBits) + instance Arbitrary Natural where arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64 @@ -395,6 +406,10 @@ class TestPrimop f where testPrimopDivLike :: String -> f -> f -> Test testPrimopDivLike _ _ _ = error "Div testing not supported for this type." + -- | Special test method for shift operations that bounds the shift amount + testPrimopShift :: String -> f -> f -> Test + testPrimopShift _ _ _ = error "Shift testing not supported for this type." + {- instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2) @@ -460,9 +475,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8# , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8# , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8# - , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# - , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# - , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# + , testPrimopShift "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8# + , testPrimopShift "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8# + , testPrimopShift "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8# , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8# , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8# , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8# @@ -482,8 +497,8 @@ testPrimops = Group "primop" , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8# , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8# , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8# - , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# - , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# + , testPrimopShift "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8# + , testPrimopShift "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8# , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8# , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8# , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8# @@ -500,9 +515,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16# , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16# , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16# - , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# - , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# - , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# + , testPrimopShift "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16# + , testPrimopShift "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16# + , testPrimopShift "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16# , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16# , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16# , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16# @@ -522,8 +537,8 @@ testPrimops = Group "primop" , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16# , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16# , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16# - , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# - , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# + , testPrimopShift "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16# + , testPrimopShift "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16# , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16# , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16# , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16# @@ -540,9 +555,9 @@ testPrimops = Group "primop" , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32# , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32# , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32# - , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# - , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# - , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# + , testPrimopShift "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32# + , testPrimopShift "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32# + , testPrimopShift "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32# , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32# , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32# , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32# @@ -562,8 +577,8 @@ testPrimops = Group "primop" , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32# , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32# , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32# - , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# - , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# + , testPrimopShift "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32# + , testPrimopShift "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32# , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32# , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32# , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32# @@ -579,9 +594,9 @@ testPrimops = Group "primop" , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64# , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64# , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64# - , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# - , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# - , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# + , testPrimopShift "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64# + , testPrimopShift "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64# + , testPrimopShift "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64# , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64# , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64# , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64# @@ -600,8 +615,8 @@ testPrimops = Group "primop" , testPrimop "or64#" Primop.or64# Wrapper.or64# , testPrimop "xor64#" Primop.xor64# Wrapper.xor64# , testPrimop "not64#" Primop.not64# Wrapper.not64# - , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# - , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# + , testPrimopShift "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64# + , testPrimopShift "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64# , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64# , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64# , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64# @@ -632,9 +647,9 @@ testPrimops = Group "primop" , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#) , testPrimop "chr#" Primop.chr# Wrapper.chr# , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word# - , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# - , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# - , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# + , testPrimopShift "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL# + , testPrimopShift "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA# + , testPrimopShift "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL# , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord# , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC# , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC# @@ -649,8 +664,8 @@ testPrimops = Group "primop" , testPrimop "or#" Primop.or# Wrapper.or# , testPrimop "xor#" Primop.xor# Wrapper.xor# , testPrimop "not#" Primop.not# Wrapper.not# - , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# - , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# + , testPrimopShift "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL# + , testPrimopShift "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL# , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int# , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord# , testPrimop "geWord#" Primop.geWord# Wrapper.geWord# @@ -709,6 +724,7 @@ instance TestPrimop (Char# -> Int#) where instance TestPrimop (Int# -> Int# -> Int#) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) @@ -741,6 +757,7 @@ instance TestPrimop (Int# -> Word#) where instance TestPrimop (Int16# -> Int# -> Int16#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt16#-> x0) (BoundedShiftAmount @Int16 shift) -> wInt16# (l x0 (uInt# shift)) === wInt16# (r x0 (uInt# shift)) instance TestPrimop (Int16# -> Int16# -> Int#) where testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -765,6 +782,7 @@ instance TestPrimop (Int16# -> Word16#) where instance TestPrimop (Int32# -> Int# -> Int32#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt32#-> x0) (BoundedShiftAmount @Int32 shift) -> wInt32# (l x0 (uInt# shift)) === wInt32# (r x0 (uInt# shift)) instance TestPrimop (Int32# -> Int32# -> Int#) where testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -789,6 +807,7 @@ instance TestPrimop (Int32# -> Word32#) where instance TestPrimop (Int64# -> Int# -> Int64#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt64#-> x0) (BoundedShiftAmount @Int64 shift) -> wInt64# (l x0 (uInt# shift)) === wInt64# (r x0 (uInt# shift)) instance TestPrimop (Int64# -> Int64# -> Int#) where testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -809,6 +828,7 @@ instance TestPrimop (Int64# -> Word64#) where instance TestPrimop (Int8# -> Int# -> Int8#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uInt8#-> x0) (BoundedShiftAmount @Int8 shift) -> wInt8# (l x0 (uInt# shift)) === wInt8# (r x0 (uInt# shift)) instance TestPrimop (Int8# -> Int8# -> Int#) where testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -833,6 +853,7 @@ instance TestPrimop (Int8# -> Word8#) where instance TestPrimop (Word# -> Int# -> Word#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord#-> x0) (BoundedShiftAmount @Word shift) -> wWord# (l x0 (uInt# shift)) === wWord# (r x0 (uInt# shift)) instance TestPrimop (Word# -> Word# -> Int#) where testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -870,6 +891,7 @@ instance TestPrimop (Word# -> Word8#) where instance TestPrimop (Word16# -> Int# -> Word16#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord16#-> x0) (BoundedShiftAmount @Word16 shift) -> wWord16# (l x0 (uInt# shift)) === wWord16# (r x0 (uInt# shift)) instance TestPrimop (Word16# -> Word16# -> Int#) where testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -894,6 +916,7 @@ instance TestPrimop (Word16# -> Word16#) where instance TestPrimop (Word32# -> Int# -> Word32#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord32#-> x0) (BoundedShiftAmount @Word32 shift) -> wWord32# (l x0 (uInt# shift)) === wWord32# (r x0 (uInt# shift)) instance TestPrimop (Word32# -> Word32# -> Int#) where testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -918,6 +941,7 @@ instance TestPrimop (Word32# -> Word32#) where instance TestPrimop (Word64# -> Int# -> Word64#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord64#-> x0) (BoundedShiftAmount @Word64 shift) -> wWord64# (l x0 (uInt# shift)) === wWord64# (r x0 (uInt# shift)) instance TestPrimop (Word64# -> Word64# -> Int#) where testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) @@ -938,6 +962,7 @@ instance TestPrimop (Word64# -> Word64#) where instance TestPrimop (Word8# -> Int# -> Word8#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1) + testPrimopShift s l r = Property s $ \ (uWord8#-> x0) (BoundedShiftAmount @Word8 shift) -> wWord8# (l x0 (uInt# shift)) === wWord8# (r x0 (uInt# shift)) instance TestPrimop (Word8# -> Word8# -> Int#) where testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) ===================================== utils/genprimopcode/Main.hs ===================================== @@ -696,7 +696,7 @@ gen_wired_in_deprecations (Info _ entries) gen_foundation_tests :: Info -> String gen_foundation_tests (Info _ entries) - = "tests =\n [ " + = "testPrimops = Group \"primop\"\n [ " ++ intercalate "\n , " (catMaybes $ map mkTest entries) ++ "\n ]\n" ++ "\n" ++ intercalate "\n" (map mkInstances testable_tys) @@ -705,12 +705,16 @@ gen_foundation_tests (Info _ entries) mkInstances inst_ty = let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r" + shift_lambda = "\\ " ++ mkArg (0::Int) (head arg_tys) ++ " (BoundedShiftAmount @" ++ dropMagicHash (head arg_tys) ++ " shift) -> " ++ mk_shift_body "l" ++ " === " ++ mk_shift_body "r" in unlines $ [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where" , " testPrimop s l r = Property s $ " ++ test_lambda ] ++ (if mb_divable_tys then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda] else []) + ++ (if mb_shiftable_tys + then [" testPrimopShift s l r = Property s $ " ++ shift_lambda] + else []) where arg_tys = args inst_ty -- eg Int -> Int -> a @@ -718,7 +722,14 @@ gen_foundation_tests (Info _ entries) [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons _ -> False + -- eg SomeType# -> Int# -> SomeType# + mb_shiftable_tys = case arg_tys of + [ty1,"Int#"] -> let res_type = getResultType inst_ty + in ty1 == res_type && ty1 `elem` shiftableTyCons + _ -> False + mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")") + mk_shift_body s = res_ty inst_ty (" (" ++ s ++ " x0 (uInt# shift))") vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys) @@ -761,6 +772,8 @@ gen_foundation_tests (Info _ entries) , (testable (ty po)) = let testPrimOpHow = if is_divLikeOp po then "testPrimopDivLike" + else if is_shiftLikeOp po + then "testPrimopShift" else "testPrimop" qualOp qualification = let qName = wrap qualification poName @@ -784,6 +797,17 @@ gen_foundation_tests (Info _ entries) testableTyCon _ = False divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" ,"Int8#", "Int16#", "Int32#", "Int64#"] + shiftableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#" + ,"Int8#", "Int16#", "Int32#", "Int64#"] + + dropMagicHash :: String -> String + dropMagicHash = takeWhile (not . (== '#')) + + getResultType :: Ty -> String + getResultType (TyF _ t2) = getResultType t2 + getResultType (TyApp (TyCon c) []) = c + getResultType (TyUTup _) = "" -- Unboxed tuples can't be shift operations + getResultType t = error $ "getResultType: unexpected type " ++ pprTy t mb_defined_bits :: Entry -> Maybe Word mb_defined_bits op@(PrimOpSpec{}) = ===================================== utils/genprimopcode/Syntax.hs ===================================== @@ -54,17 +54,23 @@ is_primtype (PrimTypeSpec {}) = True is_primtype _ = False is_divLikeOp :: Entry -> Bool -is_divLikeOp entry = case entry of - PrimOpSpec{} -> has_div_like - PseudoOpSpec{} -> has_div_like - PrimVecOpSpec{} -> has_div_like - PrimTypeSpec{} -> False - PrimVecTypeSpec{} -> False - Section{} -> False - where - has_div_like = case lookup_attrib "div_like" (opts entry) of - Just (OptionTrue{}) -> True - _ -> False +is_divLikeOp = is_likeOp "div_like" + +is_shiftLikeOp :: Entry -> Bool +is_shiftLikeOp = is_likeOp "shift_like" + +is_likeOp :: String -> Entry -> Bool +is_likeOp attrName entry = case entry of + PrimOpSpec {} -> has_attr + PseudoOpSpec {} -> has_attr + PrimVecOpSpec {} -> has_attr + PrimTypeSpec {} -> False + PrimVecTypeSpec {} -> False + Section {} -> False + where + has_attr = case lookup_attrib attrName (opts entry) of + Just (OptionTrue {}) -> True + _ -> False -- a binding of property to value data Option View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e73f3426ab6e3cf1938b538310055… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e73f3426ab6e3cf1938b538310055… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 3 commits: StgToByteCode: Don't assume that data con workers are nullary
by Marge Bot (＠marge-bot) 19 Sep '25

19 Sep '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d1d9e39e by Ben Gamari at 2025-09-19T18:24:52-04:00 StgToByteCode: Don't assume that data con workers are nullary Previously StgToByteCode assumed that all data-con workers were of a nullary representation. This is not a valid assumption, as seen in #23210, where an unsaturated application of a unary data constructor's worker resulted in invalid bytecode. Sadly, I have not yet been able to reduce a minimal testcase for this. Fixes #23210. - - - - - 3eeecd50 by Ben Gamari at 2025-09-19T18:24:53-04:00 testsuite: Mark T23146* as unbroken - - - - - 2e73f342 by sheaf at 2025-09-19T18:24:53-04:00 Add test for #26216 - - - - - 8 changed files: - compiler/GHC/StgToByteCode.hs - rts/Interpreter.c - + testsuite/tests/bytecode/T26216.hs - + testsuite/tests/bytecode/T26216.script - + testsuite/tests/bytecode/T26216.stdout - + testsuite/tests/bytecode/T26216_aux.hs - testsuite/tests/bytecode/all.T - testsuite/tests/codeGen/should_run/T23146/all.T Changes: ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -2331,11 +2331,12 @@ pushAtom d p (StgVarArg var) -- PUSH_G doesn't tag constructors. So we use PACK here -- if we are dealing with nullary constructor. case isDataConWorkId_maybe var of - Just con -> do - massert (isNullaryRepDataCon con) - return (unitOL (PACK con 0), szb) + Just con + -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make. + | isNullaryRepDataCon con -> + return (unitOL (PACK con 0), szb) - Nothing + _ -- see Note [Generating code for top-level string literal bindings] | idType var `eqType` addrPrimTy -> return (unitOL (PUSH_ADDR (getName var)), szb) ===================================== rts/Interpreter.c ===================================== @@ -2227,7 +2227,6 @@ run_BCO: // n_nptrs=1, n_ptrs=0. ASSERT(n_ptrs + n_nptrs == n_words || (n_nptrs == 1 && n_ptrs == 0)); ASSERT(n_ptrs + n_nptrs > 0); - //ASSERT(n_words > 0); // We shouldn't ever need to allocate nullary constructors for (W_ i = 0; i < n_words; i++) { con->payload[i] = (StgClosure*)ReadSpW(i); } ===================================== testsuite/tests/bytecode/T26216.hs ===================================== @@ -0,0 +1,28 @@ +{-# LANGUAGE GHC2024, BlockArguments, MagicHash #-} + +module T26216 (main) where + +import Data.Kind (Type, Constraint) +import GHC.TypeNats +import GHC.Exts (proxy#) + +import T26216_aux + +getN :: forall (n :: Nat). SNat n -> Natural +getN s = withKnownNat s (natVal s) + +type C :: forall {k}. (k -> Constraint) -> k -> Type +data C c a where { C :: c a => C c a } + +know :: forall (n :: Nat). SNat n -> C KnownNat n +know s = withKnownNat s C + +getC :: forall (n :: Nat). C KnownNat n -> Natural +getC C = natVal' (proxy# @n) + +main :: IO () +main = do + let !s = mkSome $ natSing @42 + !c = withSome s $ mkSome . know + print $ withSome s getN + print $ withSome c getC ===================================== testsuite/tests/bytecode/T26216.script ===================================== @@ -0,0 +1,2 @@ +:l T26216 +main ===================================== testsuite/tests/bytecode/T26216.stdout ===================================== @@ -0,0 +1,2 @@ +42 +42 ===================================== testsuite/tests/bytecode/T26216_aux.hs ===================================== @@ -0,0 +1,25 @@ +{-# LANGUAGE GHC2024 #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} + +module T26216_aux (Some, data Some, mkSome, withSome) where +import Data.Kind (Type) +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +type Some :: (k -> Type) -> Type +newtype Some tag = UnsafeSome (tag Any) +type role Some representational + +{-# COMPLETE Some #-} +pattern Some :: tag a -> Some tag +pattern Some x <- UnsafeSome x + where Some x = UnsafeSome ((unsafeCoerce :: tag a -> tag Any) x) + +-- | Constructor. +mkSome :: tag a -> Some tag +mkSome = \x -> UnsafeSome (unsafeCoerce x) + +-- | Eliminator. +withSome :: Some tag -> (forall a. tag a -> b) -> b +withSome (UnsafeSome thing) some = some (unsafeCoerce thing) ===================================== testsuite/tests/bytecode/all.T ===================================== @@ -5,3 +5,7 @@ test('T23068', ghci_dump_bcos + [filter_stdout_lines(r'.*bitmap: .*')], ghci_scr test('T25975', extra_ways(ghci_ways), compile_and_run, # Some of the examples work more robustly with these flags ['-fno-break-points -fno-full-laziness']) + +# Nullary data constructors +test('T26216', extra_files(["T26216_aux.hs"]), ghci_script, ['T26216.script']) + ===================================== testsuite/tests/codeGen/should_run/T23146/all.T ===================================== @@ -1,4 +1,4 @@ test('T23146', normal, compile_and_run, ['']) test('T23146_lifted', normal, compile_and_run, ['']) -test('T23146_liftedeq', expect_broken_for(23060, ghci_ways), compile_and_run, ['']) +test('T23146_liftedeq', normal, compile_and_run, ['']) test('T23146_lifted_unlifted', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1480872af6b80db1b035a444091884… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1480872af6b80db1b035a444091884… You're receiving this email because of your account on gitlab.haskell.org.

1 0