May 2026 - ghc-commits

[Git][ghc/ghc][wip/dcoutts/windows-rts-dll] 5 commits: Add minimal dlltool support into ./configure
by David Eichmann (＠DavidEichmann) 06 May '26

06 May '26

David Eichmann pushed to branch wip/dcoutts/windows-rts-dll at Glasgow Haskell Compiler / GHC Commits: 22c5938f by Duncan Coutts at 2026-05-06T16:53:06+01:00 Add minimal dlltool support into ./configure Find dlltool, and hopefully support finding it within the bundled llvm toolchain on windows. - - - - - 5488bb7f by Duncan Coutts at 2026-05-06T16:53:06+01:00 Update the default host and target files for dlltool support - - - - - 16de35d7 by Duncan Coutts at 2026-05-06T16:53:06+01:00 Add dlltool as a hadrian builder Optional except on windows. - - - - - 48044722 by Duncan Coutts at 2026-05-06T16:53:06+01:00 Update and generate libHSghc-internal.def from .def.in file The only symbol that the rts imports from the ghc-internal package now is init_ghc_hs_iface. So the rts only needs an import lib that defines that one symbol. Also, remove the libHSghc-prim.def because it is redundant. The rts no longer imports anything from ghc-prim. Keep libHSffi.def for now. We may yet need it once it is clear how libffi is going to be built/used for ghc. - - - - - 3ea6bb3f by Duncan Coutts at 2026-05-06T16:53:06+01:00 Add rule to build libHSghc-internal.dll.a and link into the rts On windows only, with dynamic linking. This is needed because on windows, all symbols in dlls must be resolved. No dangling symbols allowed. References to external symbols must be explicit. We resolve this with an import library. We create an import library for ghc-internal, a .dll.a file. This is a static archive containing .o files that define the symbols we need, and crucially have ".idata" sections that specifies the symbols the dll imports and from where. Note that we do not install this libHSghc-internal.dll.a, and it does not need to list all the symbols exported by that package. We create a special purpose import lib and only use it when linking the rts dll, so it only has to list the symbols that the rts uses from ghc-internal (which is exactly one symbol: init_ghc_hs_iface). - - - - - 15 changed files: - configure.ac - distrib/configure.ac.in - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/src/Builder.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Rts.hs - m4/find_llvm_prog.m4 - m4/fp_setup_windows_toolchain.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - rts/.gitignore - + rts/win32/libHSghc-internal.def.in - utils/ghc-toolchain/exe/Main.hs Changes: ===================================== configure.ac ===================================== @@ -314,13 +314,16 @@ else AC_CHECK_TOOL([RANLIB],[ranlib]) AC_CHECK_TOOL([OBJDUMP],[objdump]) AC_CHECK_TOOL([WindresCmd],[windres]) + AC_CHECK_TOOL([DlltoolCmd],[llvm-dlltool]) AC_CHECK_TOOL([Genlib],[genlib]) if test "$HostOS" = "mingw32"; then AC_CHECK_TARGET_TOOL([WindresCmd],[windres]) + AC_CHECK_TARGET_TOOL([DlltoolCmd],[llvm-dlltool]) AC_CHECK_TARGET_TOOL([OBJDUMP],[objdump]) WindresCmd="$(cygpath -m $WindresCmd)" + DlltoolCmd="$(cygpath -m $DlltoolCmd)" if test "$Genlib" != ""; then GenlibCmd="$(cygpath -m $Genlib)" @@ -568,6 +571,11 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** Which LLVM llvm-dlltool to use? +dnl -------------------------------------------------------------- +AC_ARG_VAR(DlltoolCmd,[Use as the path to LLVM's llvm-dlltool [default=autodetect]]) +FIND_LLVM_PROG([DlltoolCmd], [llvm-dlltool], [$LlvmMinVersion], [$LlvmMaxVersion]) + dnl ** look to see if we have a C compiler using an llvm back end. dnl FP_CC_LLVM_BACKEND @@ -1080,9 +1088,10 @@ echo "\ libdw : $UseLibdw Using LLVM tools - llc : $LlcCmd - opt : $OptCmd - llvm-as : $LlvmAsCmd" + llc : $LlcCmd + opt : $OptCmd + llvm-as : $LlvmAsCmd + llvm-dlltool : $DlltoolCmd" if test "$HSCOLOUR" = ""; then echo " ===================================== distrib/configure.ac.in ===================================== @@ -229,6 +229,13 @@ FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) +dnl ** Which LLVM llvm-dlltool to use? +dnl -------------------------------------------------------------- +AC_CHECK_TARGET_TOOL([DlltoolCmd],[llvm-dlltool]) +AC_ARG_VAR(DlltoolCmd,[Use as the path to LLVM's llvm-dlltool [default=autodetect]]) +FIND_LLVM_PROG([DlltoolCmd], [llvm-dlltool], [$LlvmMinVersion], [$LlvmMaxVersion]) +AC_SUBST([DlltoolCmd]) + dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -45,6 +45,7 @@ Target , tgtOpt = Nothing , tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtDlltool = Nothing , tgtOtool = Nothing , tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -45,6 +45,7 @@ Target , tgtOpt = @OptCmdMaybeProg@ , tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtDlltool = @DlltoolCmdMaybeProg@ , tgtOtool = @OtoolCmdMaybeProg@ , tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/src/Builder.hs ===================================== @@ -17,7 +17,7 @@ import Development.Shake.Classes import Development.Shake.Command import Development.Shake.FilePath import GHC.Generics -import GHC.Platform.ArchOS (ArchOS(..), Arch(..)) +import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..)) import qualified Hadrian.Builder as H import Hadrian.Builder hiding (Builder) import Hadrian.Builder.Ar @@ -180,6 +180,7 @@ data Builder = Alex | Objdump | Python | Ranlib + | Dlltool | Testsuite TestMode | Sphinx SphinxMode | Tar TarMode @@ -418,6 +419,7 @@ isOptional target = \case Alex -> True -- Most ar implemententions no longer need ranlib, but some still do Ranlib -> not $ Toolchain.arNeedsRanlib (tgtAr target) + Dlltool -> archOS_OS (tgtArchOs target) /= OSMinGW32 JsCpp -> not $ (archOS_arch . tgtArchOs) target == ArchJavaScript -- ArchWasm32 too? _ -> False @@ -442,6 +444,7 @@ systemBuilderPath builder = case builder of Objdump -> fromKey "objdump" Python -> fromKey "python" Ranlib -> fromTargetTC "ranlib" (maybeProg Toolchain.ranlibProgram . tgtRanlib) + Dlltool -> fromTargetTC "dlltool" (maybeProg id . tgtDlltool) Testsuite _ -> fromKey "python" Sphinx _ -> fromKey "sphinx-build" Tar _ -> fromKey "tar" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -377,6 +377,7 @@ templateRules = do , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1 , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2 ] + templateRule "rts/win32/libHSghc-internal.def" projectVersion templateRule "docs/index.html" $ packageUnitIds Stage1 templateRule "docs/users_guide/ghc_config.py" $ mconcat [ projectVersion ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -4,6 +4,8 @@ import Hadrian.BuildPath import Hadrian.Haskell.Cabal import Hadrian.Haskell.Cabal.Type import qualified Text.Parsec as Parsec +import GHC.Platform.ArchOS (ArchOS(archOS_OS), OS(..)) +import GHC.Toolchain.Target (Target(tgtArchOs)) import Base import Context @@ -185,9 +187,13 @@ jsObjects context = do srcs <- interpretInContext context (getContextData jsSrcs) mapM (objectPath context) srcs --- | Return extra object files needed to build the given library context. The --- resulting list is currently non-empty only when the package from the --- 'Context' is @ghc-internal@ built with in-tree GMP backend. +-- | Return extra object files needed to build the given library context. +-- +-- This is non-empty for: +-- +-- * @ghc-internal@ when built with in-tree GMP backend +-- * @rts@ on Windows when linking dynamically +-- extraObjects :: Context -> Action [FilePath] extraObjects context | package context == ghcInternal = do @@ -195,6 +201,13 @@ extraObjects context "gmp" -> gmpObjects (stage context) _ -> return [] + | package context == rts = do + target <- interpretInContext context getStagedTarget + builddir <- buildPath context + return [ builddir -/- "libHSghc-internal.dll.a" + | archOS_OS (tgtArchOs target) == OSMinGW32 + , Dynamic `wayUnit` way context ] + | otherwise = return [] -- | Return all the object files to be put into the library we're building for ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -24,6 +24,20 @@ rtsRules = priority 3 $ do (addRtsDummyVersion $ takeFileName rtsLibFilePath') rtsLibFilePath' + -- Solve the recursive dependency between the rts and ghc-internal + -- on Windows by creating an import lib for the ghc-internal dll, + -- to be linked into the rts dll. + forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do + let buildPath = root -/- buildDir (rtsContext stage) + buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib + +buildGhcInternalImportLib :: FilePath -> Action () +buildGhcInternalImportLib target = do + let input = "rts/win32/libHSghc-internal.def" + output = target -- the .dll.a import lib + need [input] + runBuilder Dlltool ["-d", input, "-l", output] [input] [output] + -- Need symlinks generated by rtsRules. needRtsSymLinks :: Stage -> Set.Set Way -> Action () needRtsSymLinks stage rtsWays ===================================== m4/find_llvm_prog.m4 ===================================== @@ -15,10 +15,13 @@ AC_DEFUN([FIND_LLVM_PROG],[ AC_CHECK_TOOLS([$1], [$PROG_VERSION_CANDIDATES $2], []) AS_IF([test x"$$1" != x],[ PROG_VERSION=`$$1 --version | sed -n -e 's/.*version $\([[0-9]][[0-9]]*\.$$[[0-9]][[0-9]]*\.$*[[0-9]][[0-9]]*\).*/\1/gp'` - AS_IF([test x"$PROG_VERSION" = x], - [AC_MSG_RESULT(no) - $1="" - AC_MSG_NOTICE([We only support llvm $3 upto $4 (non-inclusive) (no version found).])], + AS_IF([test x"$PROG_VERSION" = x] + [AS_IF( + [test x"$2" = x"llvm-dlltool"] + [AC_MSG_RESULT(yes)] # llvm-dlltool doesn't have a --version + [AC_MSG_RESULT(no) + AC_MSG_NOTICE([We only support llvm $3 upto $4 (non-inclusive) (no version found).])] + )], [AC_MSG_CHECKING([$$1 version ($PROG_VERSION) is between $3 and $4]) AX_COMPARE_VERSION([$PROG_VERSION], [lt], [$3], [AC_MSG_RESULT(no) ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -131,8 +131,8 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ AR="${mingwbin}llvm-ar.exe" RANLIB="${mingwbin}llvm-ranlib.exe" OBJDUMP="${mingwbin}llvm-objdump.exe" - DLLTOOL="${mingwbin}llvm-dlltool.exe" WindresCmd="${mingwbin}llvm-windres.exe" + DlltoolCmd="${mingwbin}llvm-dlltool.exe" LLC="${mingwbin}llc.exe" OPT="${mingwbin}opt.exe" LLVMAS="${mingwbin}clang.exe" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -95,6 +95,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--dlltool=$DlltoolCmd" >> acargs echo "--llc=$LlcCmd" >> acargs echo "--opt=$OptCmd" >> acargs echo "--llvm-as=$LlvmAsCmd" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -191,6 +191,7 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([DlltoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) ===================================== rts/.gitignore ===================================== @@ -20,3 +20,4 @@ /ghcautoconf.h.autoconf.in /ghcautoconf.h.autoconf /include/ghcautoconf.h +/win32/libHSghc-internal.def ===================================== rts/win32/libHSghc-internal.def.in ===================================== @@ -0,0 +1,4 @@ +LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll + +EXPORTS + init_ghc_hs_iface ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -486,7 +486,7 @@ mkTarget opts = do -- for windows, also used for cross compiling windres <- optional $ findProgram "windres" (optWindres opts) ["windres"] - dlltool <- optional $ findProgram "dlltool" (optDlltool opts) ["dlltool", "llvm-dlltool"] + dlltool <- optional $ findProgram "dlltool" (optDlltool opts) ["llvm-dlltool"] -- Darwin-specific utilities (otool, installNameTool) <- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75e4649ddc4561529a4945614cadb1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75e4649ddc4561529a4945614cadb1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/windows-rts-dll] WIP: fix FIND_LLVM_PROG bug for llvm-dlltool
by Rodrigo Mesquita (＠alt-romes) 06 May '26

06 May '26

Rodrigo Mesquita pushed to branch wip/dcoutts/windows-rts-dll at Glasgow Haskell Compiler / GHC Commits: 75e4649d by Rodrigo Mesquita at 2026-05-06T16:38:17+01:00 WIP: fix FIND_LLVM_PROG bug for llvm-dlltool - - - - - 2 changed files: - configure.ac - m4/find_llvm_prog.m4 Changes: ===================================== configure.ac ===================================== @@ -575,7 +575,6 @@ dnl ** Which LLVM llvm-dlltool to use? dnl -------------------------------------------------------------- AC_ARG_VAR(DlltoolCmd,[Use as the path to LLVM's llvm-dlltool [default=autodetect]]) FIND_LLVM_PROG([DlltoolCmd], [llvm-dlltool], [$LlvmMinVersion], [$LlvmMaxVersion]) -AC_SUBST([DlltoolCmd]) dnl ** look to see if we have a C compiler using an llvm back end. dnl ===================================== m4/find_llvm_prog.m4 ===================================== @@ -15,10 +15,13 @@ AC_DEFUN([FIND_LLVM_PROG],[ AC_CHECK_TOOLS([$1], [$PROG_VERSION_CANDIDATES $2], []) AS_IF([test x"$$1" != x],[ PROG_VERSION=`$$1 --version | sed -n -e 's/.*version $\([[0-9]][[0-9]]*\.$$[[0-9]][[0-9]]*\.$*[[0-9]][[0-9]]*\).*/\1/gp'` - AS_IF([test x"$PROG_VERSION" = x], - [AC_MSG_RESULT(no) - $1="" - AC_MSG_NOTICE([We only support llvm $3 upto $4 (non-inclusive) (no version found).])], + AS_IF([test x"$PROG_VERSION" = x] + [AS_IF( + [test x"$2" = x"llvm-dlltool"] + [AC_MSG_RESULT(yes)] # llvm-dlltool doesn't have a --version + [AC_MSG_RESULT(no) + AC_MSG_NOTICE([We only support llvm $3 upto $4 (non-inclusive) (no version found).])] + )], [AC_MSG_CHECKING([$$1 version ($PROG_VERSION) is between $3 and $4]) AX_COMPARE_VERSION([$PROG_VERSION], [lt], [$3], [AC_MSG_RESULT(no) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e4649ddc4561529a4945614cadb1a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75e4649ddc4561529a4945614cadb1a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] interface-stability/base: don't distinguish ws-32
by Marge Bot (＠marge-bot) 06 May '26

06 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a3b339a4 by Teo Camarasu at 2026-05-06T09:54:25-04:00 interface-stability/base: don't distinguish ws-32 The interface of base is identical when the Word size is 32bits. Therefore, there is no need to have another file for this case. So, we delete it. Step towards: #26752 - - - - - 1 changed file: - − testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 deleted ===================================== The diff for this file was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3b339a4ecc46345bd5e86f4dcc8045… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3b339a4ecc46345bd5e86f4dcc8045… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 6 commits: rts: Add dynamic trace flags API
by Marge Bot (＠marge-bot) 06 May '26

06 May '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 1cb1d672 by Wen Kokke at 2026-05-06T09:53:40-04:00 rts: Add dynamic trace flags API This commit adds an API to the RTS (exposed via Rts.h) that allows users to dynamically change the trace flags. Prior to this commit, users were able to stop and start the profiling and heap profiling timers (via startProfTimer/stopProfTimer and startHeapProfTimer/stopHeapProfTimer). This extends that functionality to also cover the core event types. The getTraceFlag/setTraceFlag functions read and write the values of the trace flag cache, which is allocated by Trace.c, rather than modifying the members of RtsFlags.TraceFlags. This is done under the assumption that the members of RtsFlags should not be modified after RTS initialisation. Consequently, if the user modifies the trace flags using setTraceFlag, the object returned by getTraceFlags (from base) will not reflect these changes. The trace flags are not protected by locks of any sort. Hence, these functions are not thread-safe. However, the trace flags are not modified by the RTS after initialisation, only read, so the race conditions introduced by one user modifying them are most likely benign. This PR also puts the trace flag cache in a single global struct, as opposed to a collection of global variables, and changes the types of the individual flags from uint8_t to bool, as these have the same size on both Clang and GCC and are a better semantic match. Prior to the change to uint8_t, they had type int, see 42c47cd6. Even with its deprecation in C23, I don't think there should be any issue depending on stdbool.h. The TRACE_X macros are redefined to access the global struct, with values cast to const bool to ensure they are read-only. - - - - - 9d54dc94 by Wen Kokke at 2026-05-06T09:53:40-04:00 rts: Ensure TRACE_X values are used in place of RtsFlags.TraceFlags.X - - - - - 418d737b by Wen Kokke at 2026-05-06T09:53:40-04:00 rts: Fix nonmoving-GC tracing The current nonmoving-GC tracing functions were written in a different style from the other tracing functions. They were directly implemented as, e.g., a traceConcMarkEnd function that called postConcMarkEnd. The other tracing functions are implemented as, e.g., traceThreadLabel_, a function that posts the thread label event, and traceThreadLabel, a macro that checks whether TRACE_scheduler is set. This commit fixes that implementation, and ensures that the nonmoving-GC tracing functions only emit events if nonmoving-GC tracing is enabled. - - - - - 99f4afa4 by Wen Kokke at 2026-05-06T09:53:40-04:00 rts: Add SymI_HasProto for get/setTraceFlag - - - - - 7e9eb8b9 by Wen Kokke at 2026-05-06T09:53:40-04:00 rts: Add SymI_HasProto for start/endEventLogging - - - - - 3a3045fb by Wen Kokke at 2026-05-06T09:53:41-04:00 rts: Add changelog entry - - - - - 6 changed files: - + changelog.d/dynamic-trace-flags - rts/RtsSymbols.c - rts/Trace.c - rts/Trace.h - rts/include/rts/EventLogWriter.h - rts/sm/NonMoving.c Changes: ===================================== changelog.d/dynamic-trace-flags ===================================== @@ -0,0 +1,10 @@ +section: compiler +synopsis: Support dynamic trace flags in RTS +issues: #27186 +mrs: !15936 + +description: { + The RTS API now exposes the `RUNTIME_TRACE_FLAG` type and + the `getTraceFlags` and `setTraceFlags` functions that can be used to + change the trace flags at runtime. +} ===================================== rts/RtsSymbols.c ===================================== @@ -540,7 +540,12 @@ extern char **environ; SymI_HasProto(__word_encodeFloat) \ SymI_HasDataProto(stg_atomicallyzh) \ SymI_HasProto(barf) \ + SymI_HasProto(startEventLogging) \ + SymI_HasProto(endEventLogging) \ SymI_HasProto(flushEventLog) \ + SymI_HasProto(flushEventLog) \ + SymI_HasProto(getTraceFlag) \ + SymI_HasProto(setTraceFlag) \ SymI_HasProto(deRefStablePtr) \ SymI_HasProto(debugBelch) \ SymI_HasProto(errorBelch) \ ===================================== rts/Trace.c ===================================== @@ -29,14 +29,54 @@ #include <unistd.h> #endif -// events -uint8_t TRACE_sched; -uint8_t TRACE_gc; -uint8_t TRACE_nonmoving_gc; -uint8_t TRACE_spark_sampled; -uint8_t TRACE_spark_full; -uint8_t TRACE_user; -uint8_t TRACE_cap; +RUNTIME_TRACE_FLAG_CACHE RuntimeTraceFlagCache = {0}; + +bool getTraceFlag(RUNTIME_TRACE_FLAG flag) { + switch (flag) { + case TRACE_SCHEDULER: + return RuntimeTraceFlagCache.scheduler; + case TRACE_GC: + return RuntimeTraceFlagCache.gc; + case TRACE_NONMOVING_GC: + return RuntimeTraceFlagCache.nonmoving_gc; + case TRACE_SPARK_SAMPLED: + return RuntimeTraceFlagCache.spark_sampled; + case TRACE_SPARK_FULL: + return RuntimeTraceFlagCache.spark_full; + case TRACE_USER: + return RuntimeTraceFlagCache.user; + case TRACE_CAP: + return RuntimeTraceFlagCache.cap; + default: + return false; + } +} + +void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value) { + switch (flag) { + case TRACE_SCHEDULER: + RuntimeTraceFlagCache.scheduler = value; + break; + case TRACE_GC: + RuntimeTraceFlagCache.gc = value; + break; + case TRACE_NONMOVING_GC: + RuntimeTraceFlagCache.nonmoving_gc = value; + break; + case TRACE_SPARK_SAMPLED: + RuntimeTraceFlagCache.spark_sampled = value; + break; + case TRACE_SPARK_FULL: + RuntimeTraceFlagCache.spark_full = value; + break; + case TRACE_USER: + RuntimeTraceFlagCache.user = value; + break; + case TRACE_CAP: + RuntimeTraceFlagCache.cap = value; + break; + } +} #if defined(THREADED_RTS) static Mutex trace_utx; @@ -51,43 +91,41 @@ static void traceCap_stderr(Capability *cap, char *msg, ...); --------------------------------------------------------------------------- */ /* - * Update the TRACE_* globals. Must be called whenever RtsFlags.TraceFlags is - * modified. + * Initialise the runtime trace flags from RtsFlags.TraceFlags. */ -static void updateTraceFlagCache (void) -{ - // -Ds turns on scheduler tracing too - TRACE_sched = - RtsFlags.TraceFlags.scheduler || - RtsFlags.DebugFlags.scheduler; - - // -Dg turns on gc tracing too - TRACE_gc = - RtsFlags.TraceFlags.gc || - RtsFlags.DebugFlags.gc || - RtsFlags.DebugFlags.scheduler; - - TRACE_nonmoving_gc = - RtsFlags.TraceFlags.nonmoving_gc; - - TRACE_spark_sampled = - RtsFlags.TraceFlags.sparks_sampled; - - // -Dr turns on full spark tracing - TRACE_spark_full = - RtsFlags.TraceFlags.sparks_full || - RtsFlags.DebugFlags.sparks; - - TRACE_user = - RtsFlags.TraceFlags.user; - - // We trace cap events if we're tracing anything else - TRACE_cap = - TRACE_sched || - TRACE_gc || - TRACE_spark_sampled || - TRACE_spark_full || - TRACE_user; +static void updateTraceFlagCache(void) { + // -Ds turns on scheduler tracing too + RuntimeTraceFlagCache.scheduler = + RtsFlags.TraceFlags.scheduler || + RtsFlags.DebugFlags.scheduler; + + // -Dg turns on gc tracing too + RuntimeTraceFlagCache.gc = + RtsFlags.TraceFlags.gc || + RtsFlags.DebugFlags.gc || + RtsFlags.DebugFlags.scheduler; + + RuntimeTraceFlagCache.nonmoving_gc = + RtsFlags.TraceFlags.nonmoving_gc; + + RuntimeTraceFlagCache.spark_sampled = + RtsFlags.TraceFlags.sparks_sampled; + + // -Dr turns on full spark tracing + RuntimeTraceFlagCache.spark_full = + RtsFlags.TraceFlags.sparks_full || + RtsFlags.DebugFlags.sparks; + + RuntimeTraceFlagCache.user = + RtsFlags.TraceFlags.user; + + // We trace cap events if we're tracing anything else + RuntimeTraceFlagCache.cap = + TRACE_sched || + TRACE_gc || + TRACE_spark_sampled || + TRACE_spark_full || + TRACE_user; } void initTracing (void) @@ -880,59 +918,65 @@ void traceThreadLabel_(Capability *cap, } } -void traceConcMarkBegin(void) +void traceNonmovingGcEvent_ (EventTypeNum tag) { - if (eventlog_enabled) - postEventNoCap(EVENT_CONC_MARK_BEGIN); +#if defined(DEBUG) + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* nothing - no string representation for nonmoving GC events */ + } else +#endif + { + /* currently most non-moving GC events are nullary events */ + postEventNoCap(tag); + } } -void traceConcMarkEnd(StgWord32 marked_obj_count) +void traceConcMarkEnd_(StgWord32 marked_obj_count) { - if (eventlog_enabled) +#if defined(DEBUG) + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* nothing - no string representation for nonmoving GC events */ + } else +#endif + { postConcMarkEnd(marked_obj_count); + } } -void traceConcSyncBegin(void) -{ - if (eventlog_enabled) - postEventNoCap(EVENT_CONC_SYNC_BEGIN); -} - -void traceConcSyncEnd(void) -{ - if (eventlog_enabled) - postEventNoCap(EVENT_CONC_SYNC_END); -} - -void traceConcSweepBegin(void) -{ - if (eventlog_enabled) - postEventNoCap(EVENT_CONC_SWEEP_BEGIN); -} - -void traceConcSweepEnd(void) -{ - if (eventlog_enabled) - postEventNoCap(EVENT_CONC_SWEEP_END); -} - -void traceConcUpdRemSetFlush(Capability *cap) +void traceConcUpdRemSetFlush_(Capability *cap) { - if (eventlog_enabled) +#if defined(DEBUG) + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* nothing - no string representation for nonmoving GC events */ + } else +#endif + { postConcUpdRemSetFlush(cap); + } } -void traceNonmovingHeapCensus(uint16_t blk_size, - const struct NonmovingAllocCensus *census) +void traceNonmovingHeapCensus_(uint16_t blk_size, const struct NonmovingAllocCensus *census) { - if (eventlog_enabled && TRACE_nonmoving_gc) +#if defined(DEBUG) + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* nothing - no string representation for nonmoving GC events */ + } else +#endif + { postNonmovingHeapCensus(blk_size, census); + } } -void traceNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments) +void traceNonmovingPrunedSegments_(uint32_t pruned_segments, uint32_t free_segments) { - if (eventlog_enabled && TRACE_nonmoving_gc) +#if defined(DEBUG) + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + /* nothing - no string representation for nonmoving GC events */ + } else +#endif + { postNonmovingPrunedSegments(pruned_segments, free_segments); + } } void traceThreadStatus_ (StgTSO *tso USED_IF_DEBUG) ===================================== rts/Trace.h ===================================== @@ -70,16 +70,35 @@ enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM, #define DEBUG_continuation RtsFlags.DebugFlags.continuation #define DEBUG_iomanager RtsFlags.DebugFlags.iomanager -// Event-enabled flags -// These semantically booleans but we use a dense packing to minimize their -// cache impact. -extern uint8_t TRACE_sched; -extern uint8_t TRACE_gc; -extern uint8_t TRACE_nonmoving_gc; -extern uint8_t TRACE_spark_sampled; -extern uint8_t TRACE_spark_full; -extern uint8_t TRACE_cap; -/* extern uint8_t TRACE_user; */ // only used in Trace.c +// These trace flags are shorthand for the members of the RuntimeTraceFlagCache +// struct. Within the RTS, these should be treated as read-only variables. +#define TRACE_sched ((const bool)RuntimeTraceFlagCache.scheduler) +#define TRACE_gc ((const bool)RuntimeTraceFlagCache.gc) +#define TRACE_nonmoving_gc ((const bool)RuntimeTraceFlagCache.nonmoving_gc) +#define TRACE_spark_sampled ((const bool)RuntimeTraceFlagCache.spark_sampled) +#define TRACE_spark_full ((const bool)RuntimeTraceFlagCache.spark_full) +#define TRACE_user ((const bool)RuntimeTraceFlagCache.user) +#define TRACE_cap ((const bool)RuntimeTraceFlagCache.cap) + +/* + * Runtime trace flags. + */ +typedef struct { + bool scheduler; + bool gc; + bool nonmoving_gc; + bool spark_sampled; + bool spark_full; + bool user; + bool cap; +} RUNTIME_TRACE_FLAG_CACHE; + +/* + * These flags should be used to determine whether or not some value should + * be traced at runtime, rather than the values in RtsFlags. These flags can + * be modified at runtime using setTraceFlag in `rts/EventLogWriter.h`. + */ +extern RUNTIME_TRACE_FLAG_CACHE RuntimeTraceFlagCache; // ----------------------------------------------------------------------------- // Posting events @@ -136,6 +155,52 @@ void traceGcEvent_ (Capability *cap, EventTypeNum tag); void traceGcEventAtT_ (Capability *cap, StgWord64 ts, EventTypeNum tag); +/* + * Record a nonmoving GC event. + */ +#define traceConcMarkBegin() \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingGcEvent_(EVENT_CONC_MARK_BEGIN); \ + } +#define traceConcMarkEnd(marked_obj_count) \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceConcMarkEnd_(marked_obj_count); \ + } +#define traceConcSyncBegin() \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingGcEvent_(EVENT_CONC_SYNC_BEGIN); \ + } +#define traceConcSyncEnd() \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingGcEvent_(EVENT_CONC_SYNC_END); \ + } +#define traceConcSweepBegin() \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingGcEvent_(EVENT_CONC_SWEEP_BEGIN); \ + } +#define traceConcSweepEnd() \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingGcEvent_(EVENT_CONC_SWEEP_END); \ + } +#define traceConcUpdRemSetFlush(cap) \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceConcUpdRemSetFlush_(cap); \ + } +#define traceNonmovingHeapCensus(blk_size, census) \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingHeapCensus_(blk_size, census); \ + } +#define traceNonmovingPrunedSegments(pruned_segments, free_segments) \ + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) { \ + traceNonmovingPrunedSegments_(pruned_segments, free_segments); \ + } + +void traceNonmovingGcEvent_ (EventTypeNum tag); +void traceConcMarkEnd_(StgWord32 marked_obj_count); +void traceConcUpdRemSetFlush_(Capability *cap); +void traceNonmovingHeapCensus_(uint16_t blk_size, const struct NonmovingAllocCensus *census); +void traceNonmovingPrunedSegments_(uint32_t pruned_segments, uint32_t free_segments); + /* * Record a heap event */ @@ -321,17 +386,6 @@ void traceProfSampleCostCentre(Capability *cap, void traceProfBegin(void); #endif /* PROFILING */ -void traceConcMarkBegin(void); -void traceConcMarkEnd(StgWord32 marked_obj_count); -void traceConcSyncBegin(void); -void traceConcSyncEnd(void); -void traceConcSweepBegin(void); -void traceConcSweepEnd(void); -void traceConcUpdRemSetFlush(Capability *cap); -void traceNonmovingHeapCensus(uint16_t blk_size, - const struct NonmovingAllocCensus *census); -void traceNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments); - void traceIPE(const InfoProvEnt *ipe); void flushTrace(void); @@ -384,6 +438,7 @@ void flushTrace(void); #define traceConcSweepEnd() /* nothing */ #define traceConcUpdRemSetFlush(cap) /* nothing */ #define traceNonmovingHeapCensus(blk_size, census) /* nothing */ +#define traceNonmovingPrunedSegments(pruned_segments, free_segments) /* nothing */ #define flushTrace() /* nothing */ ===================================== rts/include/rts/EventLogWriter.h ===================================== @@ -78,3 +78,34 @@ void endEventLogging(void); * Flush the eventlog. cap can be NULL if one is not held. */ void flushEventLog(Capability **cap); + +/* + * An enumeration for the runtime trace flags. + */ +typedef enum { + TRACE_SCHEDULER, + TRACE_GC, + TRACE_NONMOVING_GC, + TRACE_SPARK_SAMPLED, + TRACE_SPARK_FULL, + TRACE_USER, + TRACE_CAP, +} RUNTIME_TRACE_FLAG; + +/* + * Get the value of the given runtime trace flag. + * + * Warning: The trace flag cache is not thread-safe. After initialisation, the + * RTS never writes to these values, but concurrently using getTraceFlag and + * setTraceFlag for the same flag is a race condition. + */ +bool getTraceFlag(RUNTIME_TRACE_FLAG flag); + +/* + * Set the value of the given runtime trace flag. + * + * Warning: The trace flag cache is not thread-safe. After initialisation, the + * RTS never writes to these values. However, inconsistent reads may lead to + * incorrect tracing for a short time after setting a trace flag. + */ +void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value); ===================================== rts/sm/NonMoving.c ===================================== @@ -1339,7 +1339,7 @@ concurrent_marking: nonmovingPrintAllocatorCensus(!concurrent); #endif #if defined(TRACING) - if (RtsFlags.TraceFlags.nonmoving_gc) + if (RTS_UNLIKELY(TRACE_nonmoving_gc)) nonmovingTraceAllocatorCensus(); #endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eff6bfaf1cad8926e06a1be668e068… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/eff6bfaf1cad8926e06a1be668e068… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/issue-26717] Add a changelog entry
by Duncan Coutts (＠dcoutts) 06 May '26

06 May '26

Duncan Coutts pushed to branch wip/dcoutts/issue-26717 at Glasgow Haskell Compiler / GHC Commits: 40f43b89 by Duncan Coutts at 2026-05-06T14:45:56+01:00 Add a changelog entry - - - - - 1 changed file: - + changelog.d/T26716 Changes: ===================================== changelog.d/T26716 ===================================== @@ -0,0 +1,15 @@ +section: rts +synopsis: Fix a use-after-free bug in the poll I/O manager +issues: #26716 #26717 +mrs: !15519 +description: { + Experimental work on ASAN support for GHC (MR !15168) revealed a + use-after-free bug when using the combination of the new poll I/O + manager with the compacting GC. The ultimate cause is that a TSO's + `block_info` (used by I/O managers and many other parts of the RTS) + is sometimes a GC pointer and sometimes not, but without a consistent + and easy-to-follow rule for when this is the case. The solution has + been to clean up and enforce that the TSO's `why_blocked` enumeration + is a proper tag for the `block_info`, and to use an encoding that + determines precisely when the `block_info` is a pointer or not. +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f43b8952e55d497b046491a0a9718… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40f43b8952e55d497b046491a0a9718… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/dcoutts/windows-rts-dll] 5 commits: Add minimal dlltool support into ./configure
by David Eichmann (＠DavidEichmann) 06 May '26

06 May '26

David Eichmann pushed to branch wip/dcoutts/windows-rts-dll at Glasgow Haskell Compiler / GHC Commits: 0f8fd61a by Duncan Coutts at 2026-05-06T12:03:46+01:00 Add minimal dlltool support into ./configure Find dlltool, and hopefully support finding it within the bundled llvm toolchain on windows. - - - - - 16c5a7ec by Duncan Coutts at 2026-05-06T12:03:46+01:00 Update the default host and target files for dlltool support - - - - - 69c5d0a6 by Duncan Coutts at 2026-05-06T12:03:46+01:00 Add dlltool as a hadrian builder Optional except on windows. - - - - - 4edef246 by Duncan Coutts at 2026-05-06T12:03:46+01:00 Update and generate libHSghc-internal.def from .def.in file The only symbol that the rts imports from the ghc-internal package now is init_ghc_hs_iface. So the rts only needs an import lib that defines that one symbol. Also, remove the libHSghc-prim.def because it is redundant. The rts no longer imports anything from ghc-prim. Keep libHSffi.def for now. We may yet need it once it is clear how libffi is going to be built/used for ghc. - - - - - 56f6a49c by Duncan Coutts at 2026-05-06T12:03:46+01:00 Add rule to build libHSghc-internal.dll.a and link into the rts On windows only, with dynamic linking. This is needed because on windows, all symbols in dlls must be resolved. No dangling symbols allowed. References to external symbols must be explicit. We resolve this with an import library. We create an import library for ghc-internal, a .dll.a file. This is a static archive containing .o files that define the symbols we need, and crucially have ".idata" sections that specifies the symbols the dll imports and from where. Note that we do not install this libHSghc-internal.dll.a, and it does not need to list all the symbols exported by that package. We create a special purpose import lib and only use it when linking the rts dll, so it only has to list the symbols that the rts uses from ghc-internal (which is exactly one symbol: init_ghc_hs_iface). - - - - - 14 changed files: - configure.ac - distrib/configure.ac.in - hadrian/cfg/default.host.target.in - hadrian/cfg/default.target.in - hadrian/src/Builder.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Rules/Library.hs - hadrian/src/Rules/Rts.hs - m4/fp_setup_windows_toolchain.m4 - m4/ghc_toolchain.m4 - m4/prep_target_file.m4 - rts/.gitignore - + rts/win32/libHSghc-internal.def.in - utils/ghc-toolchain/exe/Main.hs Changes: ===================================== configure.ac ===================================== @@ -314,13 +314,16 @@ else AC_CHECK_TOOL([RANLIB],[ranlib]) AC_CHECK_TOOL([OBJDUMP],[objdump]) AC_CHECK_TOOL([WindresCmd],[windres]) + AC_CHECK_TOOL([DlltoolCmd],[llvm-dlltool]) AC_CHECK_TOOL([Genlib],[genlib]) if test "$HostOS" = "mingw32"; then AC_CHECK_TARGET_TOOL([WindresCmd],[windres]) + AC_CHECK_TARGET_TOOL([DlltoolCmd],[llvm-dlltool]) AC_CHECK_TARGET_TOOL([OBJDUMP],[objdump]) WindresCmd="$(cygpath -m $WindresCmd)" + DlltoolCmd="$(cygpath -m $DlltoolCmd)" if test "$Genlib" != ""; then GenlibCmd="$(cygpath -m $Genlib)" @@ -568,6 +571,12 @@ FIND_LLVM_PROG([OPT], [opt], [$LlvmMinVersion], [$LlvmMaxVersion]) OptCmd="$OPT" AC_SUBST([OptCmd]) +dnl ** Which LLVM llvm-dlltool to use? +dnl -------------------------------------------------------------- +AC_ARG_VAR(DlltoolCmd,[Use as the path to LLVM's llvm-dlltool [default=autodetect]]) +FIND_LLVM_PROG([DlltoolCmd], [llvm-dlltool], [$LlvmMinVersion], [$LlvmMaxVersion]) +AC_SUBST([DlltoolCmd]) + dnl ** look to see if we have a C compiler using an llvm back end. dnl FP_CC_LLVM_BACKEND @@ -1080,9 +1089,10 @@ echo "\ libdw : $UseLibdw Using LLVM tools - llc : $LlcCmd - opt : $OptCmd - llvm-as : $LlvmAsCmd" + llc : $LlcCmd + opt : $OptCmd + llvm-as : $LlvmAsCmd + llvm-dlltool : $DlltoolCmd" if test "$HSCOLOUR" = ""; then echo " ===================================== distrib/configure.ac.in ===================================== @@ -229,6 +229,13 @@ FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) +dnl ** Which LLVM llvm-dlltool to use? +dnl -------------------------------------------------------------- +AC_CHECK_TARGET_TOOL([DlltoolCmd],[llvm-dlltool]) +AC_ARG_VAR(DlltoolCmd,[Use as the path to LLVM's llvm-dlltool [default=autodetect]]) +FIND_LLVM_PROG([DlltoolCmd], [llvm-dlltool], [$LlvmMinVersion], [$LlvmMaxVersion]) +AC_SUBST([DlltoolCmd]) + dnl We know that `clang` supports `--target` and it is necessary to pass it dnl lest we see #25793. if test -z "$LlvmAsFlags" && ! test -z "$LlvmTarget"; then ===================================== hadrian/cfg/default.host.target.in ===================================== @@ -45,6 +45,7 @@ Target , tgtOpt = Nothing , tgtLlvmAs = Nothing , tgtWindres = Nothing +, tgtDlltool = Nothing , tgtOtool = Nothing , tgtInstallNameTool = Nothing } ===================================== hadrian/cfg/default.target.in ===================================== @@ -45,6 +45,7 @@ Target , tgtOpt = @OptCmdMaybeProg@ , tgtLlvmAs = @LlvmAsCmdMaybeProg@ , tgtWindres = @WindresCmdMaybeProg@ +, tgtDlltool = @DlltoolCmdMaybeProg@ , tgtOtool = @OtoolCmdMaybeProg@ , tgtInstallNameTool = @InstallNameToolCmdMaybeProg@ } ===================================== hadrian/src/Builder.hs ===================================== @@ -17,7 +17,7 @@ import Development.Shake.Classes import Development.Shake.Command import Development.Shake.FilePath import GHC.Generics -import GHC.Platform.ArchOS (ArchOS(..), Arch(..)) +import GHC.Platform.ArchOS (ArchOS(..), Arch(..), OS(..)) import qualified Hadrian.Builder as H import Hadrian.Builder hiding (Builder) import Hadrian.Builder.Ar @@ -180,6 +180,7 @@ data Builder = Alex | Objdump | Python | Ranlib + | Dlltool | Testsuite TestMode | Sphinx SphinxMode | Tar TarMode @@ -418,6 +419,7 @@ isOptional target = \case Alex -> True -- Most ar implemententions no longer need ranlib, but some still do Ranlib -> not $ Toolchain.arNeedsRanlib (tgtAr target) + Dlltool -> archOS_OS (tgtArchOs target) /= OSMinGW32 JsCpp -> not $ (archOS_arch . tgtArchOs) target == ArchJavaScript -- ArchWasm32 too? _ -> False @@ -442,6 +444,7 @@ systemBuilderPath builder = case builder of Objdump -> fromKey "objdump" Python -> fromKey "python" Ranlib -> fromTargetTC "ranlib" (maybeProg Toolchain.ranlibProgram . tgtRanlib) + Dlltool -> fromTargetTC "dlltool" (maybeProg id . tgtDlltool) Testsuite _ -> fromKey "python" Sphinx _ -> fromKey "sphinx-build" Tar _ -> fromKey "tar" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -377,6 +377,7 @@ templateRules = do , interpolateSetting "ProjectPatchLevel1" ProjectPatchLevel1 , interpolateSetting "ProjectPatchLevel2" ProjectPatchLevel2 ] + templateRule "rts/win32/libHSghc-internal.def" projectVersion templateRule "docs/index.html" $ packageUnitIds Stage1 templateRule "docs/users_guide/ghc_config.py" $ mconcat [ projectVersion ===================================== hadrian/src/Rules/Library.hs ===================================== @@ -4,6 +4,8 @@ import Hadrian.BuildPath import Hadrian.Haskell.Cabal import Hadrian.Haskell.Cabal.Type import qualified Text.Parsec as Parsec +import GHC.Platform.ArchOS (ArchOS(archOS_OS), OS(..)) +import GHC.Toolchain.Target (Target(tgtArchOs)) import Base import Context @@ -185,9 +187,13 @@ jsObjects context = do srcs <- interpretInContext context (getContextData jsSrcs) mapM (objectPath context) srcs --- | Return extra object files needed to build the given library context. The --- resulting list is currently non-empty only when the package from the --- 'Context' is @ghc-internal@ built with in-tree GMP backend. +-- | Return extra object files needed to build the given library context. +-- +-- This is non-empty for: +-- +-- * @ghc-internal@ when built with in-tree GMP backend +-- * @rts@ on Windows when linking dynamically +-- extraObjects :: Context -> Action [FilePath] extraObjects context | package context == ghcInternal = do @@ -195,6 +201,13 @@ extraObjects context "gmp" -> gmpObjects (stage context) _ -> return [] + | package context == rts = do + target <- interpretInContext context getStagedTarget + builddir <- buildPath context + return [ builddir -/- "libHSghc-internal.dll.a" + | archOS_OS (tgtArchOs target) == OSMinGW32 + , Dynamic `wayUnit` way context ] + | otherwise = return [] -- | Return all the object files to be put into the library we're building for ===================================== hadrian/src/Rules/Rts.hs ===================================== @@ -24,6 +24,20 @@ rtsRules = priority 3 $ do (addRtsDummyVersion $ takeFileName rtsLibFilePath') rtsLibFilePath' + -- Solve the recursive dependency between the rts and ghc-internal + -- on Windows by creating an import lib for the ghc-internal dll, + -- to be linked into the rts dll. + forM_ [Stage1, Stage2, Stage3 ] $ \ stage -> do + let buildPath = root -/- buildDir (rtsContext stage) + buildPath -/- "libHSghc-internal.dll.a" %> buildGhcInternalImportLib + +buildGhcInternalImportLib :: FilePath -> Action () +buildGhcInternalImportLib target = do + let input = "rts/win32/libHSghc-internal.def" + output = target -- the .dll.a import lib + need [input] + runBuilder Dlltool ["-d", input, "-l", output] [input] [output] + -- Need symlinks generated by rtsRules. needRtsSymLinks :: Stage -> Set.Set Way -> Action () needRtsSymLinks stage rtsWays ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -131,8 +131,8 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ AR="${mingwbin}llvm-ar.exe" RANLIB="${mingwbin}llvm-ranlib.exe" OBJDUMP="${mingwbin}llvm-objdump.exe" - DLLTOOL="${mingwbin}llvm-dlltool.exe" WindresCmd="${mingwbin}llvm-windres.exe" + DlltoolCmd="${mingwbin}llvm-dlltool.exe" LLC="${mingwbin}llc.exe" OPT="${mingwbin}opt.exe" LLVMAS="${mingwbin}clang.exe" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -95,6 +95,7 @@ AC_DEFUN([FIND_GHC_TOOLCHAIN], echo "--merge-objs=$MergeObjsCmd" >> acargs echo "--readelf=$READELF" >> acargs echo "--windres=$WindresCmd" >> acargs + echo "--dlltool=$DlltoolCmd" >> acargs echo "--llc=$LlcCmd" >> acargs echo "--opt=$OptCmd" >> acargs echo "--llvm-as=$LlvmAsCmd" >> acargs ===================================== m4/prep_target_file.m4 ===================================== @@ -191,6 +191,7 @@ AC_DEFUN([PREP_TARGET_FILE],[ PREP_MAYBE_SIMPLE_PROGRAM([OptCmd]) PREP_MAYBE_PROGRAM([LlvmAsCmd], [LlvmAsFlags]) PREP_MAYBE_SIMPLE_PROGRAM([WindresCmd]) + PREP_MAYBE_SIMPLE_PROGRAM([DlltoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([OtoolCmd]) PREP_MAYBE_SIMPLE_PROGRAM([InstallNameToolCmd]) PREP_MAYBE_STRING([TargetVendor_CPP]) ===================================== rts/.gitignore ===================================== @@ -20,3 +20,4 @@ /ghcautoconf.h.autoconf.in /ghcautoconf.h.autoconf /include/ghcautoconf.h +/win32/libHSghc-internal.def ===================================== rts/win32/libHSghc-internal.def.in ===================================== @@ -0,0 +1,4 @@ +LIBRARY libHSghc-internal-@ProjectVersionForLib@.0-ghc@ProjectVersion@.dll + +EXPORTS + init_ghc_hs_iface ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -486,7 +486,7 @@ mkTarget opts = do -- for windows, also used for cross compiling windres <- optional $ findProgram "windres" (optWindres opts) ["windres"] - dlltool <- optional $ findProgram "dlltool" (optDlltool opts) ["dlltool", "llvm-dlltool"] + dlltool <- optional $ findProgram "dlltool" (optDlltool opts) ["llvm-dlltool"] -- Darwin-specific utilities (otool, installNameTool) <- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a71ea50ed581978602fa704e69ea7a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a71ea50ed581978602fa704e69ea7a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] constPtrConName
by Rodrigo Mesquita (＠alt-romes) 06 May '26

06 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 64ed2f41 by Rodrigo Mesquita at 2026-05-06T13:25:50+01:00 constPtrConName - - - - - 4 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/HsToCore/Foreign/C.hs - libraries/base/src/GHC/Essentials.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -200,6 +200,9 @@ knownKeyTable , (mkVarOcc "toRational", toRationalClassOpKey) , (mkVarOcc "realToFrac", realToFracIdKey) + -- FFI things + , (mkTcOcc "ConstPtr", constPtrTyConKey) + -- Class Monad, MonadFix, MonadZip , (mkTcOcc "Monad", monadClassKey) , (thenMClassOpOcc, thenMClassOpKey) @@ -365,7 +368,7 @@ basicKnownKeyNames starArrStarArrStarKindRepName, constraintKindRepName, -- FFI primitive types that are not wired-in. - ptrTyConName, funPtrTyConName, constPtrConName, + ptrTyConName, funPtrTyConName, word8TyConName, -- Plugins @@ -459,11 +462,6 @@ pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey frontendPluginTyConName :: Name frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey -constPtrConName :: Name -constPtrConName = - tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey - - {- ************************************************************************ * * ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -241,7 +241,7 @@ dsFCall fn_id co fcall mDeclHeader = do | (_, res_ty1) <- tcSplitFunTys ty1 , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) , Just (ptr, _) <- splitTyConApp_maybe newty - , tyConName ptr == constPtrConName + , tyConName ptr `hasKnownKey` constPtrTyConKey = text "const" | otherwise = empty ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -75,6 +75,9 @@ module GHC.Essentials , Either(..) , Void + -- FFI + , ConstPtr + -- Show internals , showsPrec, shows, showString, showSpace, showCommaSpace, showParen @@ -299,6 +302,7 @@ import GHC.Internal.GHCi import GHC.Internal.Desugar (toAnnotationWrapper) import GHC.Internal.Stack.Types import GHC.Internal.Exception.Context +import GHC.Internal.Foreign.C.ConstPtr #if defined(javascript_HOST_ARCH) import GHC.Internal.JS.Prim (unsafeUnpackJSStringUtf8##) #endif ===================================== libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Foreign.C.ConstPtr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64ed2f412343e5cdc5c0694b79f61eb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64ed2f412343e5cdc5c0694b79f61eb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Introduce a cache of home module name providers
by Wolfgang Jeltsch (＠jeltsch) 06 May '26

06 May '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: 5d1d513c by Wolfgang Jeltsch at 2026-05-06T15:25:01+03:00 Introduce a cache of home module name providers This contribution introduces to the module graph a cache that maps home module names to sets of units providing them and changes the finder to use that cache. This is a performance optimization, especially for multi-home-unit builds. The particular changes are as follows: * In `GHC.Unit.Module.Graph`, `ModuleGraph` is extended with a new field `mg_home_module_name_providers_map`, exposed as `mgHomeModuleNameProvidersMap`. This is a cache that assigns to each home module name the set of IDs of home units that define it. Operations that construct module graphs are updated such that this cache stays synchronized. * In `GHC.Unit.Finder`, `findImportedModule` is changed to pull `mgHomeModuleNameProvidersMap` from `hsc_mod_graph` and pass it to `findImportedModuleNoHsc`, which now does not search home units in arbitrary order but prioritizes those units that the cache mentions as potential providers of the requested module. Resolves #27055. Co-authored-by: Wolfgang Jeltsch <wolfgang(a)well-typed.com> - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -44,6 +44,11 @@ import GHC.Data.OsPath import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module +import GHC.Unit.Module.Graph + ( + HomeModuleNameProvidersMap, + mgHomeModuleNameProvidersMap + ) import GHC.Unit.Home import GHC.Unit.Home.Graph (UnitEnvGraph) import qualified GHC.Unit.Home.Graph as HUG @@ -72,7 +77,8 @@ import GHC.Driver.Config.Finder import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.Set as Set (toList) +import Data.Set (Set) +import qualified Data.Set as Set (empty, intersection, difference, null, toList) import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE @@ -177,12 +183,13 @@ getDirHash dir = do findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult findImportedModule hsc_env mod pkg_qual = - let fc = hsc_FC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + mb_home_unit = hsc_home_unit_maybe hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags in do - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual + let home_module_name_providers_map = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod pkg_qual findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do @@ -195,55 +202,118 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv + -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts - - - home_import = case mhome_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") - + mb_home_unit_id :: Maybe UnitId + mb_home_unit_id = homeUnitId <$> mb_home_unit + + all_opts :: [(UnitId, FinderOpts)] + all_opts = case mb_home_unit_id of + Nothing -> other_fopts + Just home_unit_id -> (home_unit_id, fopts) : other_fopts + + home_import :: IO FindResult + home_import = case mb_home_unit of + Just home_unit -> findHomeModule fc fopts home_unit mod_name + Nothing -> pure $ + NoPackage (panic "findImportedModule: no home-unit") + + {- + If the module is reexported, then look for it as if it was from the + perspective of that package which reexports it. + -} + home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult home_pkg_import (uid, opts) - -- If the module is reexported, then look for it as if it was from the perspective - -- of that package which reexports it. - | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual - | elementOfUniqSet mod_name (finder_hiddenModules opts) = - return (mkHomeHidden uid) - | otherwise = - findHomePackageModule fc opts uid mod_name - - -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as - -- that is not the same!! home_import is first because we need to look within ourselves - -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts) - - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg - - unqual_import = any_home_import - `orIfNotFound` - findExposedPackageModule fc fopts units mod_name NoPkgQual - - units = case mhome_unit of - Nothing -> ue_homeUnitState ue - Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] - hpt_deps = Set.toList (homeUnitDepends units) - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + | Just real_mod_name + <- lookupUniqMap (finder_reexportedModules opts) mod_name + = findImportedModuleNoHsc fc opts ue home_module_name_providers_map + (Just $ DefiniteHomeUnit uid Nothing) + real_mod_name + NoPkgQual + | elementOfUniqSet mod_name (finder_hiddenModules opts) + = return (mkHomeHidden uid) + | otherwise + = findHomePackageModule fc opts uid mod_name + + any_home_import :: IO FindResult + any_home_import = foldr1 orIfNotFound $ + home_import :| map home_pkg_import other_fopts + {- + Do not try to be smart and change this to `foldr orIfNotFound + home_import (map home_pkg_import other_fopts)`, as that would not be the + same. `home_import` is first because we need to first look within the + current unit before looking at the other units in order. + -} + + pkg_import :: IO FindResult + pkg_import = findExposedPackageModule fc fopts unit_state mod_name mb_pkg + + unqual_import :: IO FindResult + unqual_import + = any_home_import + `orIfNotFound` + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + + unit_state :: UnitState + unit_state = case mb_home_unit_id of + Nothing -> ue_homeUnitState ue + Just home_unit_id -> HUG.homeUnitEnv_units $ + ue_findHomeUnitEnv home_unit_id ue + + home_unit_deps :: Set UnitId + home_unit_deps = homeUnitDepends unit_state + + ranked_home_unit_deps :: [UnitId] + ranked_home_unit_deps = rankedHomeUnitDeps home_module_name_providers_map + mod_name + home_unit_deps + + other_fopts :: [(UnitId, FinderOpts)] + other_fopts + = [ + (uid, opts) | + uid <- ranked_home_unit_deps, + let opts = initFinderOpts $ + homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue) + ] + +rankedHomeUnitDeps :: HomeModuleNameProvidersMap + -> ModuleName + -> Set UnitId + -> [UnitId] +rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps + = [] +rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps + = Set.toList cached_deps ++ Set.toList uncached_deps + where + + cached_providers :: Set UnitId + cached_providers = lookupWithDefaultUniqMap home_module_name_providers_map + Set.empty + mod_name + + cached_deps :: Set UnitId + cached_deps = Set.intersection home_unit_deps cached_providers + + uncached_deps :: Set UnitId + uncached_deps = Set.difference home_unit_deps cached_providers +{- + The special handling of the situation where the dependency set is empty does + not change the result, but it avoids triggering evaluation of the module + graph. +-} -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as @@ -261,15 +331,15 @@ findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env let units = hsc_units hsc_env - let mhome_unit = hsc_home_unit_maybe hsc_env - findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name + let mb_home_unit = hsc_home_unit_maybe hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mb_home_unit mod_name -- | A version of findExactModule which takes the exact parts of the HscEnv it needs -- directly. findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do - res <- case mhome_unit of +findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do + res <- case mb_home_unit of Just home_unit | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,6 +67,8 @@ module GHC.Unit.Module.Graph , mgLookupModule , mgLookupModuleName , mgHasHoles + , HomeModuleNameProvidersMap + , mgHomeModuleNameProvidersMap , showModMsg -- ** Reachability queries @@ -156,10 +158,12 @@ import GHC.Unit.Module.ModIface import GHC.Utils.Misc ( partitionWith ) import System.FilePath +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) import qualified Data.Map as Map import GHC.Types.Unique.DSet -import qualified Data.Set as Set -import Data.Set (Set) +import GHC.Types.Unique.Map (UniqMap, emptyUniqMap, listToUniqMap_C) import GHC.Unit.Module import GHC.Unit.Module.ModNodeKey import GHC.Unit.Module.Stage @@ -202,14 +206,32 @@ data ModuleGraph = ModuleGraph -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, -- This is only used for a hack in GHC.Iface.Load to do with backpack, please -- remove this at the earliest opportunity. + , mg_home_module_name_providers_map :: HomeModuleNameProvidersMap + -- ^ For each module name, which home units provide it. } +type HomeModuleNameProvidersMap = UniqMap ModuleName (Set UnitId) + +mkHomeModuleNameProvidersMap :: [ModuleGraphNode] -> HomeModuleNameProvidersMap +mkHomeModuleNameProvidersMap nodes + = listToUniqMap_C Set.union $ + [ + (moduleName, Set.singleton unitID) | + ModuleNode _ moduleNodeInfo <- nodes, + let moduleName = moduleNodeInfoModuleName moduleNodeInfo, + let unitID = moduleNodeInfoUnitId moduleNodeInfo + ] + +mgHomeModuleNameProvidersMap :: ModuleGraph -> HomeModuleNameProvidersMap +mgHomeModuleNameProvidersMap = mg_home_module_name_providers_map + -- | Why do we ever need to construct empty graphs? Is it because of one shot mode? emptyMG :: ModuleGraph emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) False + emptyUniqMap -- | Construct a module graph. This function should be the only entry point for -- building a 'ModuleGraph', since it is supposed to be built once and never modified. @@ -308,7 +330,7 @@ checkModuleGraph ModuleGraph{..} = where duplicate_errs = rights (Map.elems node_types) - node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] where -- Multiple nodes with the same key are not allowed. @@ -319,7 +341,7 @@ checkModuleGraph ModuleGraph{..} = -- | Check that all dependencies in the graph are present in the node_types map. -- This is a helper function used by checkModuleGraph. -checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) +checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) -> ModuleGraphNode -> Maybe ModuleGraphInvariantError checkAllDependenciesInGraph node_types node = @@ -334,7 +356,7 @@ checkAllDependenciesInGraph node_types node = -- | Check if for the fixed module node invariant: -- -- Fixed nodes can only depend on other fixed nodes. -checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) +checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) -> ModuleGraphNode -> Maybe ModuleGraphInvariantError checkFixedModuleInvariant node_types node = case node of @@ -484,13 +506,17 @@ isEmptyMG = null . mg_mss -- To preserve invariants, 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) - ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) - UnitNode deps uid -> UnitNode deps uid + { mg_mss = new_mss + , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) + UnitNode deps uid -> UnitNode deps uid -- | Map a function 'f' over all the 'ModSummaries', in 'IO'. -- To preserve invariants, 'f' can't change the isBoot status. @@ -856,7 +882,7 @@ moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = -- described in the export list haddocks. -------------------------------------------------------------------------------- -newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } +newtype NodeMap a = NodeMap { unNodeMap :: Map NodeKey a } deriving (Functor, Traversable, Foldable) -- | Transitive dependencies, including SOURCE edges @@ -932,7 +958,7 @@ moduleGraphNodesZero summaries = lookup_key :: ZeroScopeKey -> Maybe Int lookup_key = fmap zeroSummaryNodeKey . lookup_node - node_map :: Map.Map ZeroScopeKey ZeroSummaryNode + node_map :: Map ZeroScopeKey ZeroSummaryNode node_map = Map.fromList [ (s, node) | node <- nodes @@ -1031,7 +1057,7 @@ moduleGraphNodesStages summaries = lookup_key :: (NodeKey, ModuleStage) -> Maybe Int lookup_key = fmap stageSummaryNodeKey . lookup_node - node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode + node_map :: Map (NodeKey, ModuleStage) StageSummaryNode node_map = Map.fromList [ (s, node) | node <- nodes @@ -1049,10 +1075,13 @@ moduleGraphNodesStages summaries = extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG ModuleGraph{..} node = ModuleGraph - { mg_mss = node : mg_mss - , mg_graph = mkTransDeps (node : mg_mss) - , mg_loop_graph = mkTransLoopDeps (node : mg_mss) - , mg_zero_graph = mkTransZeroDeps (node : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_loop_graph = mkTransLoopDeps new_mss + , mg_zero_graph = mkTransZeroDeps new_mss , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) + , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss } + where + new_mss = node : mg_mss View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d1d513cc16976aea5efae2880cb655… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d1d513cc16976aea5efae2880cb655… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] 5 commits: misc fixes
by Rodrigo Mesquita (＠alt-romes) 06 May '26

06 May '26

Rodrigo Mesquita pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: c4f835f9 by Rodrigo Mesquita at 2026-05-06T11:35:55+01:00 misc fixes - - - - - 59c56053 by Rodrigo Mesquita at 2026-05-06T11:56:04+01:00 Undo 72c0e07869a4652399e669e529f1bfd456522ee0 Now KnownKey names like the ones we cared about for this previous fix must be compared explicitly by construction because we no longer have a Name! - - - - - 38033e26 by Rodrigo Mesquita at 2026-05-06T11:56:32+01:00 int8TyConName, int16TyConName, int32TyConName, int64TyConName - - - - - 5604ce26 by Rodrigo Mesquita at 2026-05-06T12:07:06+01:00 word16TyConName, word32TyConName, word64TyConName - - - - - db33d608 by Rodrigo Mesquita at 2026-05-06T12:11:31+01:00 constPtrConName - - - - - 7 changed files: - compiler/GHC/Builtin/KnownKeys.hs - compiler/GHC/Builtin/KnownOccs.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Types/Name.hs - libraries/base/src/GHC/Essentials.hs - libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs Changes: ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -200,6 +200,9 @@ knownKeyTable , (mkVarOcc "toRational", toRationalClassOpKey) , (mkVarOcc "realToFrac", realToFracIdKey) + -- FFI things + , (mkTcOcc "ConstPtr", constPtrTyConKey) + -- Class Monad, MonadFix, MonadZip , (mkTcOcc "Monad", monadClassKey) , (thenMClassOpOcc, thenMClassOpKey) @@ -365,9 +368,8 @@ basicKnownKeyNames starArrStarArrStarKindRepName, constraintKindRepName, -- FFI primitive types that are not wired-in. - ptrTyConName, funPtrTyConName, constPtrConName, - int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word8TyConName, word16TyConName, word32TyConName, word64TyConName, + ptrTyConName, funPtrTyConName, + word8TyConName, -- Plugins pluginTyConName @@ -443,19 +445,9 @@ unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerc genericClassKeys :: [KnownKey] genericClassKeys = [genClassKey, gen1ClassKey] --- Int, Word, and Addr things -int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey -int16TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int16") int16TyConKey -int32TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int32") int32TyConKey -int64TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int64") int64TyConKey - -- Word module -word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name -word8TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word8") word8TyConKey -word16TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey -word32TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey -word64TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey +word8TyConName :: Name +word8TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word8") word8TyConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name @@ -470,11 +462,6 @@ pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey frontendPluginTyConName :: Name frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey -constPtrConName :: Name -constPtrConName = - tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey - - {- ************************************************************************ * * ===================================== compiler/GHC/Builtin/KnownOccs.hs ===================================== @@ -204,9 +204,8 @@ fromStaticPtrClassOpOcc, newStablePtrIdOcc :: KnownOcc fromStaticPtrClassOpOcc = mkVarOcc "fromStaticPtr" newStablePtrIdOcc = mkVarOcc "newStablePtr" -staticPtrTyConOcc, staticPtrDataConOcc, staticPtrInfoDataConOcc :: KnownOcc +staticPtrTyConOcc, staticPtrInfoDataConOcc :: KnownOcc staticPtrTyConOcc = mkTcOcc "StaticPtr" -staticPtrDataConOcc = mkDataOcc "StaticPtr" staticPtrInfoDataConOcc = mkDataOcc "StaticPtrInfo" knownNatClassOcc, knownSymbolClassOcc, knownCharClassOcc :: KnownOcc ===================================== compiler/GHC/HsToCore/Foreign/C.hs ===================================== @@ -241,7 +241,7 @@ dsFCall fn_id co fcall mDeclHeader = do | (_, res_ty1) <- tcSplitFunTys ty1 , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) , Just (ptr, _) <- splitTyConApp_maybe newty - , tyConName ptr == constPtrConName + , tyConName ptr `hasKnownKey` constPtrTyConKey = text "const" | otherwise = empty ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -60,7 +60,6 @@ import GHC.Driver.DynFlags import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Unique (sameUnique) import GHC.Data.FastString import qualified GHC.Data.List.NonEmpty as NEL @@ -310,29 +309,29 @@ warnAboutOverflowedLiterals dflags lit , Just (i, tc) <- lit = if -- These only show up via the 'HsOverLit' route - | sameUnique tc intTyConName -> check i tc minInt maxInt - | sameUnique tc wordTyConName -> check i tc minWord maxWord - | sameUnique tc int8TyConName -> check i tc (min' @Int8) (max' @Int8) - | sameUnique tc int16TyConName -> check i tc (min' @Int16) (max' @Int16) - | sameUnique tc int32TyConName -> check i tc (min' @Int32) (max' @Int32) - | sameUnique tc int64TyConName -> check i tc (min' @Int64) (max' @Int64) - | sameUnique tc word8TyConName -> check i tc (min' @Word8) (max' @Word8) - | sameUnique tc word16TyConName -> check i tc (min' @Word16) (max' @Word16) - | sameUnique tc word32TyConName -> check i tc (min' @Word32) (max' @Word32) - | sameUnique tc word64TyConName -> check i tc (min' @Word64) (max' @Word64) - | sameUnique tc naturalTyConName -> checkPositive i tc + | tc `hasKnownKey` intTyConKey -> check i tc minInt maxInt + | tc `hasKnownKey` wordTyConKey -> check i tc minWord maxWord + | tc `hasKnownKey` int8TyConKey -> check i tc (min' @Int8) (max' @Int8) + | tc `hasKnownKey` int16TyConKey -> check i tc (min' @Int16) (max' @Int16) + | tc `hasKnownKey` int32TyConKey -> check i tc (min' @Int32) (max' @Int32) + | tc `hasKnownKey` int64TyConKey -> check i tc (min' @Int64) (max' @Int64) + | tc `hasKnownKey` word8TyConKey -> check i tc (min' @Word8) (max' @Word8) + | tc `hasKnownKey` word16TyConKey -> check i tc (min' @Word16) (max' @Word16) + | tc `hasKnownKey` word32TyConKey -> check i tc (min' @Word32) (max' @Word32) + | tc `hasKnownKey` word64TyConKey -> check i tc (min' @Word64) (max' @Word64) + | tc `hasKnownKey` naturalTyConKey -> checkPositive i tc -- These only show up via the 'HsLit' route - | sameUnique tc intPrimTyConName -> check i tc minInt maxInt - | sameUnique tc wordPrimTyConName -> check i tc minWord maxWord - | sameUnique tc int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) - | sameUnique tc int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) - | sameUnique tc int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) - | sameUnique tc int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) - | sameUnique tc word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) - | sameUnique tc word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) - | sameUnique tc word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) - | sameUnique tc word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) + | tc `hasKnownKey` intPrimTyConKey -> check i tc minInt maxInt + | tc `hasKnownKey` wordPrimTyConKey -> check i tc minWord maxWord + | tc `hasKnownKey` int8PrimTyConKey -> check i tc (min' @Int8) (max' @Int8) + | tc `hasKnownKey` int16PrimTyConKey -> check i tc (min' @Int16) (max' @Int16) + | tc `hasKnownKey` int32PrimTyConKey -> check i tc (min' @Int32) (max' @Int32) + | tc `hasKnownKey` int64PrimTyConKey -> check i tc (min' @Int64) (max' @Int64) + | tc `hasKnownKey` word8PrimTyConKey -> check i tc (min' @Word8) (max' @Word8) + | tc `hasKnownKey` word16PrimTyConKey -> check i tc (min' @Word16) (max' @Word16) + | tc `hasKnownKey` word32PrimTyConKey -> check i tc (min' @Word32) (max' @Word32) + | tc `hasKnownKey` word64PrimTyConKey -> check i tc (min' @Word64) (max' @Word64) | otherwise -> return () ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -165,34 +165,6 @@ import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique, The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. []) All built-in syntax things are WiredIn. - -Note [Fast comparison for built-in Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this wired-in Name in GHC.Builtin.KnownKeys: - - int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey - -Ultimately this turns into something like: - - int8TyConName = Name gHC_INTERNAL_INT (mkOccName ..."Int8") int8TyConKey - -So a comparison like `x == int8TyConName` will turn into `getUnique x == -int8TyConKey`, nice and efficient. But if the `n_occ` field is strict, that -definition will look like: - - int8TyConName = case (mkOccName..."Int8") of occ -> - Name gHC_INTERNAL_INT occ int8TyConKey - -and now the comparison will not optimise. This matters even more when there are -numerous comparisons (see #19386): - -if | tc == int8TyCon -> ... - | tc == int16TyCon -> ... - ...etc... - -when we would like to get a single multi-branched case. - -TL;DR: we make the `n_occ` field lazy. -} {- ******************************************************************* @@ -207,11 +179,8 @@ data Name = Name { n_sort :: NameSort -- ^ What sort of name it is - , n_occ :: OccName + , n_occ :: !OccName -- ^ Its occurrence name. - -- - -- NOTE: kept lazy to allow known names to be known constructor applications - -- and to inline better. See Note [Fast comparison for built-in Names] , n_uniq :: {-# UNPACK #-} !Unique -- ^ Its unique. ===================================== libraries/base/src/GHC/Essentials.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash, Trustworthy, RankNTypes #-} +{-# LANGUAGE MagicHash, Trustworthy, RankNTypes, CPP #-} -- | -- @@ -75,6 +75,9 @@ module GHC.Essentials , Either(..) , Void + -- FFI + , ConstPtr + -- Show internals , showsPrec, shows, showString, showSpace, showCommaSpace, showParen @@ -138,7 +141,7 @@ module GHC.Essentials -- Static pointers , IsStatic( fromStaticPtr ), makeStatic - , StaticPtr( StaticPtr ), StaticPtrInfo( StaticPtrInfo ) + , StaticPtr, StaticPtrInfo( StaticPtrInfo ) -- Stable pointers , StablePtr, newStablePtr @@ -157,9 +160,6 @@ module GHC.Essentials , CS.unpackAppendCStringUtf8#, CS.cstringLength# , eqString, inline - -- JS primitives - , unsafeUnpackJSStringUtf8## - , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof -- Typeable and type representations @@ -237,6 +237,11 @@ module GHC.Essentials , ExceptionContext, emptyExceptionContext , toAnnotationWrapper + +#if defined(javascript_HOST_ARCH) + -- JS primitives + , unsafeUnpackJSStringUtf8## +#endif ) where import GHC.Internal.Base hiding( foldr ) @@ -276,7 +281,7 @@ import GHC.Internal.Word( Word8(W8#), Word16(W16#), Word32(W32#), Word64(W64#) ) import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) -import GHC.Internal.StaticPtr( IsStatic(..), StaticPtr(..), StaticPtrInfo(..) ) +import GHC.Internal.StaticPtr( IsStatic(..), StaticPtr, StaticPtrInfo(..) ) import GHC.Internal.StaticPtr.Internal( makeStatic ) import GHC.Internal.Stable( StablePtr, newStablePtr ) @@ -297,4 +302,7 @@ import GHC.Internal.GHCi import GHC.Internal.Desugar (toAnnotationWrapper) import GHC.Internal.Stack.Types import GHC.Internal.Exception.Context +import GHC.Internal.Foreign.C.ConstPtr +#if defined(javascript_HOST_ARCH) import GHC.Internal.JS.Prim (unsafeUnpackJSStringUtf8##) +#endif ===================================== libraries/ghc-internal/src/GHC/Internal/Foreign/C/ConstPtr.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fdefine-known-key-names #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.Foreign.C.ConstPtr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a207cbcf5265d0a81d32ba744dccc6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a207cbcf5265d0a81d32ba744dccc6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/facundominguez/generalize-inline-so
by Torsten Schmits (＠torsten.schmits) 06 May '26

06 May '26

Torsten Schmits pushed new branch wip/facundominguez/generalize-inline-so at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/facundominguez/generalize-inl… You're receiving this email because of your account on gitlab.haskell.org.

1 0