- ghc-commits - Haskell.org

[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

[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: 813ce36c by Duncan Coutts at 2026-05-06T11:31:56+01:00 Add minimal dlltool support into ./configure Find dlltool, and hopefully support finding it within the bundled llvm toolchain on windows. - - - - - 4cfe78cd by Duncan Coutts at 2026-05-06T11:31:56+01:00 Update the default host and target files for dlltool support - - - - - 82880197 by Duncan Coutts at 2026-05-06T11:31:56+01:00 Add dlltool as a hadrian builder Optional except on windows. - - - - - b6bdebf9 by Duncan Coutts at 2026-05-06T11:31:56+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. - - - - - a71ea50e by Duncan Coutts at 2026-05-06T11:31:56+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)" @@ -1080,9 +1083,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,12 @@ FIND_LLVM_PROG([LLVMAS], [clang], [$LlvmMinVersion], [$LlvmMaxVersion]) LlvmAsCmd="$LLVMAS" AC_SUBST([LlvmAsCmd]) +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 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/fba86f1ea1a6e50df6aed3d3ba6635… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fba86f1ea1a6e50df6aed3d3ba6635… You're receiving this email because of your account on gitlab.haskell.org.

1 0

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

06 May '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6ff44d56 by Wen Kokke at 2026-05-06T05:23:13-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. - - - - - 9b66c2e4 by Wen Kokke at 2026-05-06T05:23:13-04:00 rts: Ensure TRACE_X values are used in place of RtsFlags.TraceFlags.X - - - - - 8f42ce61 by Wen Kokke at 2026-05-06T05:23:13-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. - - - - - a16ece7a by Wen Kokke at 2026-05-06T05:23:13-04:00 rts: Add SymI_HasProto for get/setTraceFlag - - - - - 0ddddde9 by Wen Kokke at 2026-05-06T05:23:13-04:00 rts: Add SymI_HasProto for start/endEventLogging - - - - - 0b2b3eeb by Wen Kokke at 2026-05-06T05:23:13-04:00 rts: Add changelog entry - - - - - be21a344 by Teo Camarasu at 2026-05-06T05:23:14-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 - - - - - 7 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 - − testsuite/tests/interface-stability/base-exports.stdout-ws-32 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 ===================================== 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/-/compare/d3ab500d9a3dc2ed07820a59ef5cb4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3ab500d9a3dc2ed07820a59ef5cb4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/abstract-q] Make Q abstract
by Teo Camarasu (＠teo) 06 May '26

06 May '26

Teo Camarasu pushed to branch wip/abstract-q at Glasgow Haskell Compiler / GHC Commits: 44cc53fe by Teo Camarasu at 2026-05-06T09:24:24+01:00 Make Q abstract This patch aims to clearly demarcate the internal and external interface of Q. In the past the `Quasi` typeclass was both part of the external, public-facing interface, and was used to give the implementation of `Q`. Now we separate out these two distinct roles. `Quasi` continues to exist in the public interface, but we introduce a new `MetaHandlers` type, which is equivalent to `Dict Quasi`. `Q a` is now defined to be `MetaHandlers IO -> IO a`, and, crucially, the constructor and the new `MetaHandlers` type are not exposed from the public interface. This gives us the ability to vary the interface on the GHC side without forcing a breaking change on the `template-haskell` side. Similarly `template-haskell` has more freedom to change the `Quasi` typeclass without needing any changes in `lib:ghc`. Implements https://github.com/ghc-proposals/ghc-proposals/pull/70 - - - - - 9 changed files: - + changelog.d/AbstractQ - compiler/GHC/Data/IOEnv.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Gen/Splice.hs-boot - libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs - libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== changelog.d/AbstractQ ===================================== @@ -0,0 +1,7 @@ +section: template-haskell +synopsis: Hide the implementation of Q +description: The constructor of Q is now hidden. + This is done to improve the stability of ``template-haskell``. + To minimize breakage, we have added a new ``qRunQ`` operation to ``Quasi``. +mrs: !15696 +issues: TODO ===================================== compiler/GHC/Data/IOEnv.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Data.IOEnv ( -- I/O operations IORef, newMutVar, readMutVar, writeMutVar, updMutVar, - atomicUpdMutVar, atomicUpdMutVar' + atomicUpdMutVar, atomicUpdMutVar', unliftIOEnv ) where import GHC.Prelude @@ -258,3 +258,10 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnvIO #-} updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) + +unliftIOEnv :: forall env b. ((forall a. IOEnv env a -> IO a) -> IO b) -> IOEnv env b +unliftIOEnv k = IOEnv $ \env -> + let + unlift :: forall a. IOEnv env a -> IO a + unlift (IOEnv m) = m env + in k unlift ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -25,7 +25,7 @@ module GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket, runAnnotation, getUntypedSpliceBody, - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + runMetaE, runMetaP, runMetaT, runMetaD, runQinTcM, tcTopSpliceExpr, lookupThName_maybe, defaultRunMeta, runMeta', runRemoteModFinalizers, finishTH, runTopSplice @@ -138,6 +138,7 @@ import qualified GHC.LanguageExtensions as LangExt -- THSyntax gives access to internal functions and data types import qualified GHC.Boot.TH.Syntax as TH import qualified GHC.Boot.TH.Monad as TH +import GHC.Boot.TH.Monad (MetaHandlers(..)) import qualified GHC.Boot.TH.Ppr as TH #if defined(HAVE_INTERNAL_INTERPRETER) @@ -1138,8 +1139,8 @@ convertAnnotationWrapper fhv = do ************************************************************************ -} -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act +runQinTcM :: TH.Q a -> TcM a +runQinTcM (TH.Q act) = unliftIOEnv $ \runInIO -> liftIO $ act (metaHandlersTcM runInIO) runRemoteModFinalizers :: ThModFinalizers -> TcM () runRemoteModFinalizers (ThModFinalizers finRefs) = do @@ -1152,7 +1153,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs + runQinTcM $ sequence_ qs #endif ExternalInterp ext -> withExtInterp ext $ \inst -> do @@ -1466,70 +1467,14 @@ when showing an error message. To call runQ in the Tc monad, we need to make TcM an instance of Quasi: -} -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } +-- 'msg' is forced to ensure exceptions don't escape, +-- see Note [Exceptions in TH] +report :: Bool -> [Char] -> TcM () +report True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg +report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg - - qLocation :: TcM TH.Loc - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - RealSrcSpan s _ -> return s - GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" - (pprGeneratedSrcSpanDetails) - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitString (moduleUnit m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qGetPackageRoot = do - dflags <- getDynFlags - return $ fromMaybe "." (workingDirectory dflags) - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddDependentDirectory dp = do - ref <- fmap tcg_dependent_dirs getGblEnv - dep_dirs <- readTcRef ref - writeTcRef ref (dp:dep_dirs) - - qAddTempFile suffix = do - dflags <- getDynFlags - logger <- getLogger - tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - - qAddTopDecls thds = do +addTopDecls :: [TH.Dec] -> TcM () +addTopDecls thds = do exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin @@ -1557,52 +1502,13 @@ instance TH.Quasi TcM where bindName :: RdrName -> TcM () bindName (Exact n) = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnTHError $ AddInvalidCorePlugin plugin - case r of - Found {} -> addErr err - FoundMultiple {} -> addErr err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - - qPutDoc doc_loc s = do +putDoc :: TH.DocLoc -> String -> TcM () +putDoc doc_loc s = do th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc @@ -1624,15 +1530,133 @@ instance TH.Quasi TcM where checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n checkLocalName ModuleDoc = pure True - - qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc - qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc - qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i - qGetDoc TH.ModuleDoc = do +getDoc :: TH.DocLoc -> TcM (Maybe String) +getDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc +getDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc +getDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i +getDoc TH.ModuleDoc = do df <- getDynFlags docs <- getGblEnv >>= extractDocs df return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) +getQ :: forall a. Typeable a => TcM (Maybe a) +getQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + +location :: TcM TH.Loc +location = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan{} -> pprPanic "qLocation: generatedSrcSpan" + (pprGeneratedSrcSpanDetails) + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + +metaHandlersTcM :: (forall x. TcM x -> IO x) -> TH.MetaHandlers IO +metaHandlersTcM runInIO = TH.MetaHandlers { + mLiftIO = id + -- We are careful to use the TcM instance not the one for IO, since that would lead to a different error. + , mFail = \s -> runInIO $ fail @TcM s + , mNewName = \s -> runInIO $ do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + , mReport = fmap runInIO . report + + , mLocation = runInIO location + + , mLookupName = fmap runInIO . lookupName + , mReify = runInIO . reify + , mReifyFixity = \nm -> runInIO $ lookupThName nm >>= reifyFixity + , mReifyType = runInIO . reifyTypeOfThing + , mReifyInstances = fmap runInIO . reifyInstances + , mReifyRoles = runInIO . reifyRoles + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = runInIO . reifyModule + , mReifyConStrictness = \nm -> runInIO $ do + { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + -- NB: extremely subtle!!! TODO: write up note + -- tryTcDiscardingErrs manipulates the reader env so we need to be careful we don't sneak in the outside env + , mRecover = \recover main -> runInIO $ tryTcDiscardingErrs (runQinTcM recover) (runQinTcM main) + + , mGetPackageRoot = runInIO $ do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + , mAddDependentFile = \fp -> runInIO $ do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + , mAddDependentDirectory = \dp -> runInIO $ do + ref <- fmap tcg_dependent_dirs getGblEnv + dep_dirs <- readTcRef ref + writeTcRef ref (dp:dep_dirs) + + , mAddTempFile = \suffix -> runInIO $ do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + , mAddTopDecls = runInIO . addTopDecls + + , mAddForeignFilePath = \lang fp -> runInIO $ do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + , mAddModFinalizer = \fin -> runInIO $ do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + , mAddCorePlugin = \plugin -> runInIO $ do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnTHError $ AddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + , mGetQ = runInIO getQ + + , mPutQ = \x -> runInIO $ do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + , mIsExtEnabled = runInIO . xoptM + + , mExtsEnabled = runInIO $ + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + , mPutDoc = fmap runInIO . putDoc + + , mGetDoc = runInIO . getDoc + } + -- | Looks up documentation for a declaration in first the current module, -- otherwise tries to find it in another module via 'hscGetModuleInterface'. lookupDeclDoc :: Name -> TcM (Maybe String) @@ -1788,7 +1812,7 @@ runTH ty fhv = do InternalInterp -> do -- Run it in the local TcM hv <- liftIO $ wormhole interp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) + r <- runQinTcM (unsafeCoerce hv :: TH.Q a) return r #endif @@ -1797,7 +1821,7 @@ runTH ty fhv = do -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. rstate <- getTHState inst - loc <- TH.qLocation + loc <- location -- run a remote TH request r <- liftIO $ withForeignRef rstate $ \state_hv -> @@ -1913,32 +1937,32 @@ wrapTHResult tcm = do handleTHMessage :: THMessage a -> TcM a handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + NewName a -> wrapTHResult $ runQinTcM $ TH.newName a + Report b str -> wrapTHResult $ runQinTcM $ TH.report b str + LookupName b str -> wrapTHResult $ runQinTcM $ TH.lookupName b str + Reify n -> wrapTHResult $ runQinTcM $ TH.reify n + ReifyFixity n -> wrapTHResult $ runQinTcM $ TH.reifyFixity n + ReifyType n -> wrapTHResult $ runQinTcM $ TH.reifyType n + ReifyInstances n ts -> wrapTHResult $ runQinTcM $ TH.reifyInstances n ts + ReifyRoles n -> wrapTHResult $ runQinTcM $ TH.reifyRoles n ReifyAnnotations lookup tyrep -> wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + ReifyModule m -> wrapTHResult $ runQinTcM $ TH.reifyModule m + ReifyConStrictness nm -> wrapTHResult $ runQinTcM $ TH.reifyConStrictness nm + GetPackageRoot -> wrapTHResult $ runQinTcM $ TH.getPackageRoot + AddDependentFile f -> wrapTHResult $ runQinTcM $ TH.addDependentFile f + AddDependentDirectory d -> wrapTHResult $ runQinTcM $ TH.addDependentDirectory d + AddTempFile s -> wrapTHResult $ runQinTcM $ TH.addTempFile s AddModFinalizer r -> do interp <- hscInterp <$> getTopEnv wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - PutDoc l s -> wrapTHResult $ TH.qPutDoc l s - GetDoc l -> wrapTHResult $ TH.qGetDoc l + AddCorePlugin str -> wrapTHResult $ runQinTcM $ TH.addCorePlugin str + AddTopDecls decs -> wrapTHResult $ runQinTcM $ TH.addTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ runQinTcM $ TH.addForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ runQinTcM $ TH.isExtEnabled ext + ExtsEnabled -> wrapTHResult $ runQinTcM $ TH.extsEnabled + PutDoc l s -> wrapTHResult $ runQinTcM $ TH.putDoc l s + GetDoc l -> wrapTHResult $ runQinTcM $ TH.getDoc l FailIfErrs -> wrapTHResult failIfErrsM _ -> panic ("handleTHMessage: unexpected message " ++ show msg) ===================================== compiler/GHC/Tc/Gen/Splice.hs-boot ===================================== @@ -42,6 +42,6 @@ runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs) runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -runQuasi :: TH.Q a -> TcM a +runQinTcM :: TH.Q a -> TcM a runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Lib.hs ===================================== @@ -1079,7 +1079,7 @@ withDecDoc :: String -> Q Dec -> Q Dec withDecDoc doc dec = do dec' <- dec case doc_loc dec' of - Just loc -> qAddModFinalizer $ qPutDoc loc doc + Just loc -> addModFinalizer $ putDoc loc doc Nothing -> pure () pure dec' where @@ -1128,7 +1128,7 @@ funD_doc :: Name -> [Q Clause] -> [Maybe String] -- ^ Documentation to attach to arguments -> Q Dec funD_doc nm cs mfun_doc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs] let dec = funD nm cs case mfun_doc of @@ -1145,7 +1145,7 @@ dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1159,7 +1159,7 @@ newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the newtype declaration -> Q Dec newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeD ctxt tc tvs ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1172,7 +1172,7 @@ typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind) -- ^ Documentation to attach to the data declaration -> Q Dec typeDataD_doc tc tvs ksig cons_with_docs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) maybe dec (flip withDecDoc dec) mdoc @@ -1186,7 +1186,7 @@ dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind) -- ^ Documentation to attach to the instance declaration -> Q Dec dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do - qAddModFinalizer $ mapM_ docCons cons_with_docs + addModFinalizer $ mapM_ docCons cons_with_docs let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs) derivs maybe dec (flip withDecDoc dec) mdoc @@ -1202,7 +1202,7 @@ newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -- ^ Documentation to attach to the instance declaration -> Q Dec newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do - qAddModFinalizer $ docCons con_with_docs + addModFinalizer $ docCons con_with_docs let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs maybe dec (flip withDecDoc dec) mdoc @@ -1212,7 +1212,7 @@ patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat -> [Maybe String] -- ^ Documentation to attach to the pattern arguments -> Q Dec patSynD_doc name args dir pat mdoc arg_docs = do - qAddModFinalizer $ sequence_ + addModFinalizer $ sequence_ [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs] let dec = patSynD name args dir pat maybe dec (flip withDecDoc dec) mdoc ===================================== libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Types (TYPE, RuntimeRep(..)) #else import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..), Monoid(..), Semigroup(..), String, - flip, id, (.), (++), + flip, id, (.), (++), ($), ) import GHC.Internal.Classes (not) import GHC.Internal.Data.Data hiding (Fixity(..)) @@ -59,145 +59,137 @@ import GHC.Internal.ForeignSrcLang import GHC.Internal.LanguageExtensions import GHC.Internal.TH.Syntax ------------------------------------------------------ --- --- The Quasi class --- ------------------------------------------------------ - -class (MonadIO m, MonadFail m) => Quasi m where - -- | Fresh names. See 'newName'. - qNewName :: String -> m Name - - ------- Error reporting and recovery ------- - -- | Report an error (True) or warning (False) - -- ...but carry on; use 'fail' to stop. See 'report'. - qReport :: Bool -> String -> m () - - -- | See 'recover'. - qRecover :: m a -- ^ the error handler - -> m a -- ^ action which may fail - -> m a -- ^ Recover from the monadic 'fail' - - ------- Inspect the type-checker's environment ------- - -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. - qLookupName :: Bool -> String -> m (Maybe Name) - -- | See 'reify'. - qReify :: Name -> m Info - -- | See 'reifyFixity'. - qReifyFixity :: Name -> m (Maybe Fixity) - -- | See 'reifyType'. - qReifyType :: Name -> m Type - -- | Is (n tys) an instance? Returns list of matching instance Decs (with - -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. - qReifyInstances :: Name -> [Type] -> m [Dec] - -- | See 'reifyRoles'. - qReifyRoles :: Name -> m [Role] - -- | See 'reifyAnnotations'. - qReifyAnnotations :: Data a => AnnLookup -> m [a] - -- | See 'reifyModule'. - qReifyModule :: Module -> m ModuleInfo - -- | See 'reifyConStrictness'. - qReifyConStrictness :: Name -> m [DecidedStrictness] - - -- | See 'location'. - qLocation :: m Loc - - -- | Input/output (dangerous). See 'runIO'. - qRunIO :: IO a -> m a - qRunIO = liftIO - -- | See 'getPackageRoot'. - qGetPackageRoot :: m FilePath - - -- | See 'addDependentFile'. - qAddDependentFile :: FilePath -> m () - - -- | See 'addDependentDirectory'. - qAddDependentDirectory :: FilePath -> m () - - -- | See 'addTempFile'. - qAddTempFile :: String -> m FilePath - - -- | See 'addTopDecls'. - qAddTopDecls :: [Dec] -> m () - - -- | See 'addForeignFilePath'. - qAddForeignFilePath :: ForeignSrcLang -> String -> m () - - -- | See 'addModFinalizer'. - qAddModFinalizer :: Q () -> m () - - -- | See 'addCorePlugin'. - qAddCorePlugin :: String -> m () - - -- | See 'getQ'. - qGetQ :: Typeable a => m (Maybe a) - - -- | See 'putQ'. - qPutQ :: Typeable a => a -> m () - - -- | See 'isExtEnabled'. - qIsExtEnabled :: Extension -> m Bool - -- | See 'extsEnabled'. - qExtsEnabled :: m [Extension] - - -- | See 'putDoc'. - qPutDoc :: DocLoc -> String -> m () - -- | See 'getDoc'. - qGetDoc :: DocLoc -> m (Maybe String) +data MetaHandlers m = MetaHandlers { + mLiftIO :: forall a. IO a -> m a + , mFail :: forall a. String -> m a + -- | Fresh names. See 'newName'. + , mNewName :: String -> m Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + , mReport :: Bool -> String -> m () + + -- | See 'recover'. + , mRecover :: forall a. Q a -- ^ the error handler + -> Q a -- ^ action which may fail + -> m a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + , mLookupName :: Bool -> String -> m (Maybe Name) + -- | See 'reify'. + , mReify :: Name -> m Info + -- | See 'reifyFixity'. + , mReifyFixity :: Name -> m (Maybe Fixity) + -- | See 'reifyType'. + , mReifyType :: Name -> m Type + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + , mReifyInstances :: Name -> [Type] -> m [Dec] + -- | See 'reifyRoles'. + , mReifyRoles :: Name -> m [Role] + -- | See 'reifyAnnotations'. + , mReifyAnnotations :: forall a. Data a => AnnLookup -> m [a] + -- | See 'reifyModule'. + , mReifyModule :: Module -> m ModuleInfo + -- | See 'reifyConStrictness'. + , mReifyConStrictness :: Name -> m [DecidedStrictness] + + -- | See 'location'. + , mLocation :: m Loc + + -- | See 'getPackageRoot'. + , mGetPackageRoot :: m FilePath + + -- | See 'addDependentFile'. + , mAddDependentFile :: FilePath -> m () + + -- | See 'addDependentDirectory'. + , mAddDependentDirectory :: FilePath -> m () + + -- | See 'addTempFile'. + , mAddTempFile :: String -> m FilePath + + -- | See 'addTopDecls'. + , mAddTopDecls :: [Dec] -> m () + + -- | See 'addForeignFilePath'. + , mAddForeignFilePath :: ForeignSrcLang -> String -> m () + + -- | See 'addModFinalizer'. + , mAddModFinalizer :: Q () -> m () + + -- | See 'addCorePlugin'. + , mAddCorePlugin :: String -> m () + + -- | See 'getQ'. + , mGetQ :: forall a. Typeable a => m (Maybe a) + + -- | See 'putQ'. + , mPutQ :: forall a. Typeable a => a -> m () + + -- | See 'isExtEnabled'. + , mIsExtEnabled :: Extension -> m Bool + -- | See 'extsEnabled'. + , mExtsEnabled :: m [Extension] + + -- | See 'putDoc'. + , mPutDoc :: DocLoc -> String -> m () + -- | See 'getDoc'. + , mGetDoc :: DocLoc -> m (Maybe String) + } ------------------------------------------------------ --- The IO instance of Quasi ------------------------------------------------------ +badIO :: String -> IO a +badIO op = do { hPutStrLn stderr ("Can't do `" ++ op ++ "' in the IO monad") + ; fail "Template Haskell failure" } --- | This instance is used only when running a Q --- computation in the IO monad, usually just to --- print the result. There is no interesting --- type environment, so reification isn't going to --- work. -instance Quasi IO where - qNewName = newNameIO - - qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) - - qLookupName _ _ = badIO "lookupName" - qReify _ = badIO "reify" - qReifyFixity _ = badIO "reifyFixity" - qReifyType _ = badIO "reifyFixity" - qReifyInstances _ _ = badIO "reifyInstances" - qReifyRoles _ = badIO "reifyRoles" - qReifyAnnotations _ = badIO "reifyAnnotations" - qReifyModule _ = badIO "reifyModule" - qReifyConStrictness _ = badIO "reifyConStrictness" - qLocation = badIO "currentLocation" - qRecover _ _ = badIO "recover" -- Maybe we could fix this? - qGetPackageRoot = badIO "getProjectRoot" - qAddDependentFile _ = badIO "addDependentFile" - qAddTempFile _ = badIO "addTempFile" - qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFilePath _ _ = badIO "addForeignFilePath" - qAddModFinalizer _ = badIO "addModFinalizer" - qAddCorePlugin _ = badIO "addCorePlugin" - qGetQ = badIO "getQ" - qPutQ _ = badIO "putQ" - qIsExtEnabled _ = badIO "isExtEnabled" - qExtsEnabled = badIO "extsEnabled" - qPutDoc _ _ = badIO "putDoc" - qGetDoc _ = badIO "getDoc" - qAddDependentDirectory _ = badIO "AddDependentDirectory" +metaHandlersIO :: MetaHandlers IO +metaHandlersIO = MetaHandlers { + mLiftIO = id + , mFail = fail + , mNewName = newNameIO + , mReport = \b msg -> + if b then + hPutStrLn stderr ("Template Haskell error: " ++ msg) + else + hPutStrLn stderr ("Template Haskell error: " ++ msg) -- TODO: should this be different from above? + , mLookupName = \ _ _ -> badIO "lookupName" + , mReify = \_ -> badIO "reify" + , mReifyFixity = \_ -> badIO "reifyFixity" + , mReifyType = \_ -> badIO "reifyFixity" + , mReifyInstances = \_ _ -> badIO "reifyInstances" + , mReifyRoles = \_ -> badIO "reifyRoles" + , mReifyAnnotations = \_ -> badIO "reifyAnnotations" + , mReifyModule = \_ -> badIO "reifyModule" + , mReifyConStrictness = \_ -> badIO "reifyConStrictness" + , mLocation = badIO "currentLocation" + , mRecover = \_ _ -> badIO "recover" -- Maybe we could fix this? + , mGetPackageRoot = badIO "getProjectRoot" + , mAddDependentFile = \_ -> badIO "addDependentFile" + , mAddTempFile = \_ -> badIO "addTempFile" + , mAddTopDecls = \_ -> badIO "addTopDecls" + , mAddForeignFilePath = \_ _ -> badIO "addForeignFilePath" + , mAddModFinalizer = \_ -> badIO "addModFinalizer" + , mAddCorePlugin = \_ -> badIO "addCorePlugin" + , mGetQ = badIO "getQ" + , mPutQ = \_ -> badIO "putQ" + , mIsExtEnabled = \_ -> badIO "isExtEnabled" + , mExtsEnabled = badIO "extsEnabled" + , mPutDoc = \_ _ -> badIO "putDoc" + , mGetDoc = \_ -> badIO "getDoc" + , mAddDependentDirectory = \_ -> badIO "AddDependentDirectory" + } instance Quote IO where newName = newNameIO + + newNameIO :: String -> IO Name newNameIO s = do { n <- atomicModifyIORef' counter (\x -> (x + 1, x)) ; pure (mkNameU s n) } -badIO :: String -> IO a -badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") - ; fail "Template Haskell failure" } - -- Global variable to generate unique symbols counter :: IORef Uniq {-# NOINLINE counter #-} @@ -220,36 +212,22 @@ counter = unsafePerformIO (newIORef 0) -- inversion](https://en.wikipedia.org/wiki/Dependency_inversion_principle), -- providing an abstract interface for the user which is later concretely -- fufilled by an concrete 'Quasi' instance, internal to GHC. -newtype Q a = Q { unQ :: forall m. Quasi m => m a } - --- | \"Runs\" the 'Q' monad. Normal users of Template Haskell --- should not need this function, as the splice brackets @$( ... )@ --- are the usual way of running a 'Q' computation. --- --- This function is primarily used in GHC internals, and for debugging --- splices by running them in 'IO'. --- --- Note that many functions in 'Q', such as 'reify' and other compiler --- queries, are not supported when running 'Q' in 'IO'; these operations --- simply fail at runtime. Indeed, the only operations guaranteed to succeed --- are 'newName', 'runIO', 'reportError' and 'reportWarning'. -runQ :: Quasi m => Q a -> m a -runQ (Q m) = m +newtype Q a = Q { unQ :: MetaHandlers IO -> IO a } instance Monad Q where - Q m >>= k = Q (m >>= \x -> unQ (k x)) + Q m >>= k = Q $ \h -> (m h >>= \x -> unQ (k x) h) (>>) = (*>) instance MonadFail Q where - fail s = report True s >> Q (fail "Q monad failure") + fail s = report True s >> Q (\h -> mFail h "Q monad failure") instance Functor Q where - fmap f (Q x) = Q (fmap f x) + fmap f (Q x) = Q $ \h -> fmap f (x h) instance Applicative Q where - pure x = Q (pure x) - Q f <*> Q x = Q (f <*> x) - Q m *> Q n = Q (m *> n) + pure x = Q $ \_ -> pure x + Q f <*> Q x = Q $ \h -> (f h <*> x h) + Q m *> Q n = Q $ \h -> (m h *> n h) -- | @since 2.17.0.0 instance Semigroup a => Semigroup (Q a) where @@ -319,7 +297,7 @@ class Monad m => Quote m where newName :: String -> m Name instance Quote Q where - newName s = Q (qNewName s) + newName s = Q $ \h -> mNewName h s ----------------------------------------------------- -- @@ -517,7 +495,7 @@ joinCode = flip bindCode id -- | Report an error (True) or warning (False), -- but carry on; use 'fail' to stop. report :: Bool -> String -> Q () -report b s = Q (qReport b s) +report b s = Q $ \h -> mReport h b s {-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6 -- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'. @@ -532,20 +510,20 @@ reportWarning = report False recover :: Q a -- ^ handler to invoke on failure -> Q a -- ^ computation to run -> Q a -recover (Q r) (Q m) = Q (qRecover r m) +recover rec main = Q $ \h -> mRecover h rec main -- We don't export lookupName; the Bool isn't a great API -- Instead we export lookupTypeName, lookupValueName lookupName :: Bool -> String -> Q (Maybe Name) -lookupName ns s = Q (qLookupName ns s) +lookupName ns s = Q $ \h -> mLookupName h ns s -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupTypeName :: String -> Q (Maybe Name) -lookupTypeName s = Q (qLookupName True s) +lookupTypeName s = Q $ \h -> mLookupName h True s -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details. lookupValueName :: String -> Q (Maybe Name) -lookupValueName s = Q (qLookupName False s) +lookupValueName s = Q $ \h -> mLookupName h False s {- Note [Name lookup] @@ -620,7 +598,7 @@ To ensure we get information about @D@-the-value, use 'lookupValueName': and to get information about @D@-the-type, use 'lookupTypeName'. -} reify :: Name -> Q Info -reify v = Q (qReify v) +reify v = Q $ \h -> mReify h v {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then @@ -629,7 +607,7 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then 'Nothing', so you may assume @bar@ has 'defaultFixity'. -} reifyFixity :: Name -> Q (Maybe Fixity) -reifyFixity nm = Q (qReifyFixity nm) +reifyFixity nm = Q $ \h -> mReifyFixity h nm {- | @reifyType nm@ attempts to find the type or kind of @nm@. For example, @reifyType 'not@ returns @Bool -> Bool@, and @@ -637,7 +615,7 @@ reifyFixity nm = Q (qReifyFixity nm) This works even if there's no explicit signature and the type or kind is inferred. -} reifyType :: Name -> Q Type -reifyType nm = Q (qReifyType nm) +reifyType nm = Q $ \h -> mReifyType h nm {- | Template Haskell is capable of reifying information about types and terms defined in previous declaration groups. Top-level declaration splices break up @@ -729,7 +707,7 @@ has some discussion around this. -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] -reifyInstances cls tys = Q (qReifyInstances cls tys) +reifyInstances cls tys = Q $ \h -> mReifyInstances h cls tys {- | @reifyRoles nm@ returns the list of roles associated with the parameters (both visible and invisible) of @@ -748,20 +726,20 @@ and @reifyRoles Proxy@, we will get @['NominalR', 'PhantomR']@. The 'NominalR' i the role of the invisible @k@ parameter. Kind parameters are always nominal. -} reifyRoles :: Name -> Q [Role] -reifyRoles nm = Q (qReifyRoles nm) +reifyRoles nm = Q $ \h -> mReifyRoles h nm -- | @reifyAnnotations target@ returns the list of annotations -- associated with @target@. Only the annotations that are -- appropriately typed is returned. So if you have @Int@ and @String@ -- annotations for the same target, you have to call this function twice. reifyAnnotations :: Data a => AnnLookup -> Q [a] -reifyAnnotations an = Q (qReifyAnnotations an) +reifyAnnotations an = Q $ \h -> mReifyAnnotations h an -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return -- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo -reifyModule m = Q (qReifyModule m) +reifyModule m = Q $ \h -> mReifyModule h m -- | @reifyConStrictness nm@ looks up the strictness information for the fields -- of the constructor with the name @nm@. Note that the strictness information @@ -776,7 +754,7 @@ reifyModule m = Q (qReifyModule m) -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the -- @-XStrictData@ language extension was enabled. reifyConStrictness :: Name -> Q [DecidedStrictness] -reifyConStrictness n = Q (qReifyConStrictness n) +reifyConStrictness n = Q $ \h -> mReifyConStrictness h n -- | Is the list of instances returned by 'reifyInstances' nonempty? -- @@ -789,7 +767,7 @@ isInstance nm tys = do { decs <- reifyInstances nm tys -- | The location at which this computation is spliced. location :: Q Loc -location = Q qLocation +location = Q mLocation -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad. -- Take care: you are guaranteed the ordering of calls to 'runIO' within @@ -799,7 +777,7 @@ location = Q qLocation -- necessarily flushed when the compiler finishes running, so you should -- flush them yourself. runIO :: IO a -> Q a -runIO m = Q (qRunIO m) +runIO m = Q $ \h -> mLiftIO h m -- | Get the package root for the current package which is being compiled. -- This can be set explicitly with the -package-root flag but is normally @@ -811,7 +789,7 @@ runIO m = Q (qRunIO m) -- change directory when compiling files but instead set the -package-root flag -- appropriately. getPackageRoot :: Q FilePath -getPackageRoot = Q qGetPackageRoot +getPackageRoot = Q mGetPackageRoot -- | Record external directories that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -830,7 +808,7 @@ getPackageRoot = Q qGetPackageRoot -- * The state of the directory is read at the interface generation time, -- not at the time of the function call. addDependentDirectory :: FilePath -> Q () -addDependentDirectory dp = Q (qAddDependentDirectory dp) +addDependentDirectory dp = Q $ \h -> mAddDependentDirectory h dp -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file @@ -844,17 +822,17 @@ addDependentDirectory dp = Q (qAddDependentDirectory dp) -- -- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () -addDependentFile fp = Q (qAddDependentFile fp) +addDependentFile fp = Q $ \h -> mAddDependentFile h fp -- | Obtain a temporary file path with the given suffix. The compiler will -- delete this file after compilation. addTempFile :: String -> Q FilePath -addTempFile suffix = Q (qAddTempFile suffix) +addTempFile suffix = Q $ \h -> mAddTempFile h suffix -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () -addTopDecls ds = Q (qAddTopDecls ds) +addTopDecls ds = Q $ \h -> mAddTopDecls h ds -- | Same as 'addForeignSource', but expects to receive a path pointing to the -- foreign file instead of a 'String' of its contents. Consider using this in @@ -863,7 +841,7 @@ addTopDecls ds = Q (qAddTopDecls ds) -- This is a good alternative to 'addForeignSource' when you are trying to -- directly link in an object file. addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () -addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) +addForeignFilePath lang fp = Q $ \h -> mAddForeignFilePath h lang fp -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. @@ -872,7 +850,7 @@ addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- 'reify' is able to find the local definitions when executed inside the -- finalizer. addModFinalizer :: Q () -> Q () -addModFinalizer act = Q (qAddModFinalizer (unQ act)) +addModFinalizer act = Q $ \h -> mAddModFinalizer h act -- | Adds a core plugin to the compilation pipeline. -- @@ -882,7 +860,7 @@ addModFinalizer act = Q (qAddModFinalizer (unQ act)) -- to tell the compiler that we needed to compile first a plugin module in the -- current package. addCorePlugin :: String -> Q () -addCorePlugin plugin = Q (qAddCorePlugin plugin) +addCorePlugin plugin = Q $ \h -> mAddCorePlugin h plugin -- | Get state from the 'Q' monad. The state maintained by 'Q' is isomorphic to -- a type-indexed finite map. That is, @@ -896,20 +874,20 @@ addCorePlugin plugin = Q (qAddCorePlugin plugin) -- Note that the state is local to the Haskell module in which the Template -- Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) -getQ = Q qGetQ +getQ = Q mGetQ -- | Replace the state in the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. putQ :: Typeable a => a -> Q () -putQ x = Q (qPutQ x) +putQ x = Q $ \h -> mPutQ h x -- | Determine whether the given language extension is enabled in the 'Q' monad. isExtEnabled :: Extension -> Q Bool -isExtEnabled ext = Q (qIsExtEnabled ext) +isExtEnabled ext = Q $ \h -> mIsExtEnabled h ext -- | List all enabled language extensions. extsEnabled :: Q [Extension] -extsEnabled = Q qExtsEnabled +extsEnabled = Q mExtsEnabled -- | Add Haddock documentation to the specified location. This will overwrite -- any documentation at the location if it already exists. This will reify the @@ -928,48 +906,18 @@ extsEnabled = Q qExtsEnabled -- Adding documentation to anything outside of the current module will cause an -- error. putDoc :: DocLoc -> String -> Q () -putDoc t s = Q (qPutDoc t s) +putDoc t s = Q $ \h -> mPutDoc h t s -- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag. getDoc :: DocLoc -> Q (Maybe String) -getDoc n = Q (qGetDoc n) +getDoc n = Q $ \h -> mGetDoc h n instance MonadIO Q where liftIO = runIO -instance Quasi Q where - qNewName = newName - qReport = report - qRecover = recover - qReify = reify - qReifyFixity = reifyFixity - qReifyType = reifyType - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness = reifyConStrictness - qLookupName = lookupName - qLocation = location - qGetPackageRoot = getPackageRoot - qAddDependentFile = addDependentFile - qAddDependentDirectory = addDependentDirectory - qAddTempFile = addTempFile - qAddTopDecls = addTopDecls - qAddForeignFilePath = addForeignFilePath - qAddModFinalizer = addModFinalizer - qAddCorePlugin = addCorePlugin - qGetQ = getQ - qPutQ = putQ - qIsExtEnabled = isExtEnabled - qExtsEnabled = extsEnabled - qPutDoc = putDoc - qGetDoc = getDoc - - ---------------------------------------------------- -- The following operations are used solely in GHC.HsToCore.Quote when -- desugaring brackets. They are not necessary for the user, who can use ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric, - TupleSections, RecordWildCards, InstanceSigs, CPP #-} + TupleSections, RecordWildCards, InstanceSigs, CPP, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -- | @@ -164,58 +164,70 @@ ghcCmd m = GHCiQ $ \sRef -> do instance MonadIO GHCiQ where liftIO m = GHCiQ $ \_ -> m -instance TH.Quasi GHCiQ where - qNewName str = ghcCmd (NewName str) - qReport isError msg = ghcCmd (Report isError msg) - - -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do - s <- readIORef sRef - remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef - remoteTHCall (qsPipe s) (EndRecover (isLeft e)) - case e of - Left GHCiQException{} -> h sRef - Right r -> return r - qLookupName isType occ = ghcCmd (LookupName isType occ) - qReify name = ghcCmd (Reify name) - qReifyFixity name = ghcCmd (ReifyFixity name) - qReifyType name = ghcCmd (ReifyType name) - qReifyInstances name tys = ghcCmd (ReifyInstances name tys) - qReifyRoles name = ghcCmd (ReifyRoles name) - -- To reify annotations, we send GHC the AnnLookup and also the -- TypeRep of the thing we're looking for, to avoid needing to -- serialize irrelevant annotations. - qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] - qReifyAnnotations lookup = +reifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a] +reifyAnnotations lookup = map (deserializeWithData . B.unpack) <$> ghcCmd (ReifyAnnotations lookup typerep) where typerep = typeOf (undefined :: a) - qReifyModule m = ghcCmd (ReifyModule m) - qReifyConStrictness name = ghcCmd (ReifyConStrictness name) - qLocation = fromMaybe noLoc . qsLocation <$> getState - qGetPackageRoot = ghcCmd GetPackageRoot - qAddDependentFile file = ghcCmd (AddDependentFile file) - qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir) - qAddTempFile suffix = ghcCmd (AddTempFile suffix) - qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>= +runQinGHCiQ :: TH.Q a -> GHCiQ a +runQinGHCiQ (TH.Q m) = GHCiQ $ \sRef -> m (metaHandlersGHCiQ (runInIO sRef)) + where + runInIO :: IORef QState -> GHCiQ a -> IO a + runInIO sRef (GHCiQ m) = m sRef + +metaHandlersGHCiQ :: (forall x. GHCiQ x -> IO x) -> TH.MetaHandlers IO +metaHandlersGHCiQ runInIO = TH.MetaHandlers { + mLiftIO = id + , mFail = runInIO . fail + , mNewName = \str -> runInIO $ ghcCmd (NewName str) + , mReport = \isError msg -> runInIO $ ghcCmd (Report isError msg) + + -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice + , mRecover = \h a -> runInIO $ GHCiQ $ \sRef -> mask $ \unmask -> do + s <- readIORef sRef + remoteTHCall (qsPipe s) StartRecover + e <- try $ unmask $ runGHCiQ (runQinGHCiQ a <* ghcCmd FailIfErrs) sRef + remoteTHCall (qsPipe s) (EndRecover (isLeft e)) + case e of + Left GHCiQException{} -> + runGHCiQ (runQinGHCiQ h) sRef + Right r -> return r + , mLookupName = \isType occ -> runInIO $ ghcCmd (LookupName isType occ) + , mReify = \name ->runInIO $ ghcCmd (Reify name) + , mReifyFixity = \name ->runInIO $ ghcCmd (ReifyFixity name) + , mReifyType = \name -> runInIO $ ghcCmd (ReifyType name) + , mReifyInstances = \name tys -> runInIO $ ghcCmd (ReifyInstances name tys) + , mReifyRoles = \name -> runInIO $ ghcCmd (ReifyRoles name) + + , mReifyAnnotations = runInIO . reifyAnnotations + , mReifyModule = \m -> runInIO $ ghcCmd (ReifyModule m) + , mReifyConStrictness = \name -> runInIO $ ghcCmd (ReifyConStrictness name) + , mLocation = runInIO $ fromMaybe noLoc . qsLocation <$> getState + , mGetPackageRoot = runInIO $ ghcCmd GetPackageRoot + , mAddDependentFile = \file -> runInIO $ ghcCmd (AddDependentFile file) + , mAddDependentDirectory = \dir -> runInIO $ ghcCmd (AddDependentDirectory dir) + , mAddTempFile = \suffix -> runInIO $ ghcCmd (AddTempFile suffix) + , mAddTopDecls = \decls -> runInIO $ ghcCmd (AddTopDecls decls) + , mAddForeignFilePath = \lang fp -> runInIO $ ghcCmd (AddForeignFilePath lang fp) + , mAddModFinalizer = \fin -> runInIO $ GHCiQ (\_ -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer - qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = do + , mAddCorePlugin = \str -> runInIO $ ghcCmd (AddCorePlugin str) + , mGetQ = runInIO $ do s <- getState let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m return $ lookup (qsMap s) - qPutQ k = GHCiQ $ \sRef -> - modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) - qIsExtEnabled x = ghcCmd (IsExtEnabled x) - qExtsEnabled = ghcCmd ExtsEnabled - qPutDoc l s = ghcCmd (PutDoc l s) - qGetDoc l = ghcCmd (GetDoc l) + , mPutQ = \k -> runInIO $ GHCiQ $ \sRef -> + modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) + , mIsExtEnabled = \x -> runInIO $ ghcCmd (IsExtEnabled x) + , mExtsEnabled = runInIO $ ghcCmd ExtsEnabled + , mPutDoc = \l s -> runInIO $ ghcCmd (PutDoc l s) + , mGetDoc = \l -> runInIO $ ghcCmd (GetDoc l) +} -- | The implementation of the 'StartTH' message: create -- a new IORef QState, and return a RemoteRef to it. @@ -235,7 +247,7 @@ runModFinalizerRefs pipe rstate qrefs = do qstateref <- localRef rstate qstate <- readIORef qstateref qstate' <- newIORef $ qstate { qsPipe = pipe } - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate' + _ <- runGHCiQ (runQinGHCiQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message @@ -272,5 +284,5 @@ runTHQ runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) - r <- runGHCiQ (TH.runQ ghciq) qstateref + r <- runGHCiQ (runQinGHCiQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -11,7 +11,9 @@ module Language.Haskell.TH.Syntax ( Exp (..), Match (..), Clause (..), - Q (..), + Q, + -- backwards compatibility + Language.Haskell.TH.Syntax.unQ, Pat (..), Stmt (..), Con (..), @@ -207,6 +209,8 @@ import System.FilePath import Data.Data hiding (Fixity(..)) import Data.List.NonEmpty (NonEmpty(..)) import GHC.Lexeme ( startsVarSym, startsVarId ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.IO (hPutStrLn, stderr) -- This module completely re-exports 'GHC.Boot.TH.Syntax', -- and exports additionally functions that depend on @filepath@ or @System.IO@. @@ -499,3 +503,180 @@ reassociate the tree as necessary. -- Subsumed by the more general 'SpecialiseEP' constructor. pattern SpecialiseP :: Name -> Type -> (Maybe Inline) -> Phases -> Pragma pattern SpecialiseP nm ty inl phases = SpecialiseEP Nothing [] (SigE (VarE nm) ty) inl phases + +unQ :: Q a -> (forall m. Quasi m => m a) +unQ m = runQ m + +----------------------------------------------------- +-- +-- The Quasi class +-- +----------------------------------------------------- + +class (MonadIO m, MonadFail m) => Quasi m where + qRunQ :: Q a -> m a + -- | Fresh names. See 'newName'. + qNewName :: String -> m Name + + ------- Error reporting and recovery ------- + -- | Report an error (True) or warning (False) + -- ...but carry on; use 'fail' to stop. See 'report'. + qReport :: Bool -> String -> m () + + -- | See 'recover'. + qRecover :: m a -- ^ the error handler + -> m a -- ^ action which may fail + -> m a -- ^ Recover from the monadic 'fail' + + ------- Inspect the type-checker's environment ------- + -- | True <=> type namespace, False <=> value namespace. See 'lookupName'. + qLookupName :: Bool -> String -> m (Maybe Name) + -- | See 'reify'. + qReify :: Name -> m Info + -- | See 'reifyFixity'. + qReifyFixity :: Name -> m (Maybe Fixity) + -- | See 'reifyType'. + qReifyType :: Name -> m Type + -- | Is (n tys) an instance? Returns list of matching instance Decs (with + -- empty sub-Decs) Works for classes and type functions. See 'reifyInstances'. + qReifyInstances :: Name -> [Type] -> m [Dec] + -- | See 'reifyRoles'. + qReifyRoles :: Name -> m [Role] + -- | See 'reifyAnnotations'. + qReifyAnnotations :: Data a => AnnLookup -> m [a] + -- | See 'reifyModule'. + qReifyModule :: Module -> m ModuleInfo + -- | See 'reifyConStrictness'. + qReifyConStrictness :: Name -> m [DecidedStrictness] + + -- | See 'location'. + qLocation :: m Loc + + -- | Input/output (dangerous). See 'runIO'. + qRunIO :: IO a -> m a + qRunIO = liftIO + -- | See 'getPackageRoot'. + qGetPackageRoot :: m FilePath + + -- | See 'addDependentFile'. + qAddDependentFile :: FilePath -> m () + + -- | See 'addDependentDirectory'. + qAddDependentDirectory :: FilePath -> m () + + -- | See 'addTempFile'. + qAddTempFile :: String -> m FilePath + + -- | See 'addTopDecls'. + qAddTopDecls :: [Dec] -> m () + + -- | See 'addForeignFilePath'. + qAddForeignFilePath :: ForeignSrcLang -> String -> m () + + -- | See 'addModFinalizer'. + qAddModFinalizer :: Q () -> m () + + -- | See 'addCorePlugin'. + qAddCorePlugin :: String -> m () + + -- | See 'getQ'. + qGetQ :: Typeable a => m (Maybe a) + + -- | See 'putQ'. + qPutQ :: Typeable a => a -> m () + + -- | See 'isExtEnabled'. + qIsExtEnabled :: Extension -> m Bool + -- | See 'extsEnabled'. + qExtsEnabled :: m [Extension] + + -- | See 'putDoc'. + qPutDoc :: DocLoc -> String -> m () + -- | See 'getDoc'. + qGetDoc :: DocLoc -> m (Maybe String) + +-- | \"Runs\" the 'Q' monad. Normal users of Template Haskell +-- should not need this function, as the splice brackets @$( ... )@ +-- are the usual way of running a 'Q' computation. +-- +-- This function is primarily used in GHC internals, and for debugging +-- splices by running them in 'IO'. +-- +-- Note that many functions in 'Q', such as 'reify' and other compiler +-- queries, are not supported when running 'Q' in 'IO'; these operations +-- simply fail at runtime. Indeed, the only operations guaranteed to succeed +-- are 'newName', 'runIO', 'reportError' and 'reportWarning'. +runQ :: Quasi m => Q a -> m a +runQ = qRunQ + +----------------------------------------------------- +-- The IO instance of Quasi +----------------------------------------------------- + +-- | This instance is used only when running a Q +-- computation in the IO monad, usually just to +-- print the result. There is no interesting +-- type environment, so reification isn't going to +-- work. +instance Quasi IO where + qRunQ (Q m) = m metaHandlersIO + qNewName = newNameIO + + qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg) + + qLookupName _ _ = badIO "lookupName" + qReify _ = badIO "reify" + qReifyFixity _ = badIO "reifyFixity" + qReifyType _ = badIO "reifyFixity" + qReifyInstances _ _ = badIO "reifyInstances" + qReifyRoles _ = badIO "reifyRoles" + qReifyAnnotations _ = badIO "reifyAnnotations" + qReifyModule _ = badIO "reifyModule" + qReifyConStrictness _ = badIO "reifyConStrictness" + qLocation = badIO "currentLocation" + qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qGetPackageRoot = badIO "getProjectRoot" + qAddDependentFile _ = badIO "addDependentFile" + qAddTempFile _ = badIO "addTempFile" + qAddTopDecls _ = badIO "addTopDecls" + qAddForeignFilePath _ _ = badIO "addForeignFilePath" + qAddModFinalizer _ = badIO "addModFinalizer" + qAddCorePlugin _ = badIO "addCorePlugin" + qGetQ = badIO "getQ" + qPutQ _ = badIO "putQ" + qIsExtEnabled _ = badIO "isExtEnabled" + qExtsEnabled = badIO "extsEnabled" + qPutDoc _ _ = badIO "putDoc" + qGetDoc _ = badIO "getDoc" + qAddDependentDirectory _ = badIO "AddDependentDirectory" + +instance Quasi Q where + qRunQ = id + qNewName = newName + qReport = report + qRecover = recover + qReify = reify + qReifyFixity = reifyFixity + qReifyType = reifyType + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness = reifyConStrictness + qLookupName = lookupName + qLocation = location + qGetPackageRoot = getPackageRoot + qAddDependentFile = addDependentFile + qAddDependentDirectory = addDependentDirectory + qAddTempFile = addTempFile + qAddTopDecls = addTopDecls + qAddForeignFilePath = addForeignFilePath + qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin + qGetQ = getQ + qPutQ = putQ + qIsExtEnabled = isExtEnabled + qExtsEnabled = extsEnabled + qPutDoc = putDoc + qGetDoc = getDoc ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -354,7 +354,6 @@ module Language.Haskell.TH where type Pred = Type type PredQ :: * type PredQ = Q Pred - type role Q nominal type Q :: * -> * newtype Q a = ... type Quote :: (* -> *) -> Constraint @@ -655,7 +654,7 @@ module Language.Haskell.TH where roleAnnotD :: forall (m :: * -> *). Quote m => Name -> [GHC.Internal.TH.Lib.Role] -> m Dec ruleVar :: forall (m :: * -> *). Quote m => Name -> m RuleBndr runIO :: forall a. GHC.Internal.Types.IO a -> Q a - runQ :: forall (m :: * -> *) a. GHC.Internal.TH.Monad.Quasi m => Q a -> m a + runQ :: forall (m :: * -> *) a. Language.Haskell.TH.Syntax.Quasi m => Q a -> m a safe :: Safety sectionL :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp sectionR :: forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp @@ -1703,11 +1702,11 @@ module Language.Haskell.TH.Syntax where data Pragma = InlineP Name Inline RuleMatch Phases | OpaqueP Name | SpecialiseEP (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp (GHC.Internal.Maybe.Maybe Inline) Phases | SpecialiseInstP Type | RuleP GHC.Internal.Base.String (GHC.Internal.Maybe.Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP GHC.Internal.Types.Int GHC.Internal.Base.String | CompleteP [Name] (GHC.Internal.Maybe.Maybe Name) | SCCP Name (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) type Pred :: * type Pred = Type - type role Q nominal type Q :: * -> * - newtype Q a = Q {unQ :: forall (m :: * -> *). Quasi m => m a} + newtype Q a = ... type Quasi :: (* -> *) -> Constraint class (GHC.Internal.Control.Monad.IO.Class.MonadIO m, GHC.Internal.Control.Monad.Fail.MonadFail m) => Quasi m where + qRunQ :: forall a. Q a -> m a qNewName :: GHC.Internal.Base.String -> m Name qReport :: GHC.Internal.Types.Bool -> GHC.Internal.Base.String -> m () qRecover :: forall a. m a -> m a -> m a @@ -1730,13 +1729,13 @@ module Language.Haskell.TH.Syntax where qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m () qAddModFinalizer :: Q () -> m () qAddCorePlugin :: GHC.Internal.Base.String -> m () - qGetQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) - qPutQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () + qGetQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => m (GHC.Internal.Maybe.Maybe a) + qPutQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> m () qIsExtEnabled :: Extension -> m GHC.Internal.Types.Bool qExtsEnabled :: m [Extension] qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m () qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) - {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} + {-# MINIMAL qRunQ, qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-} type Quote :: (* -> *) -> Constraint class GHC.Internal.Base.Monad m => Quote m where newName :: GHC.Internal.Base.String -> m Name @@ -1814,7 +1813,7 @@ module Language.Haskell.TH.Syntax where falseName :: Name getDoc :: DocLoc -> Q (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) getPackageRoot :: Q GHC.Internal.IO.FilePath - getQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) + getQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => Q (GHC.Internal.Maybe.Maybe a) get_cons_names :: Con -> [Name] hoistCode :: forall (m :: * -> *) (n :: * -> *) (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r). GHC.Internal.Base.Monad m => (forall x. m x -> n x) -> Code m a -> Code n a isExtEnabled :: Extension -> Q GHC.Internal.Types.Bool @@ -1861,7 +1860,7 @@ module Language.Haskell.TH.Syntax where oneName :: Name pkgString :: PkgName -> GHC.Internal.Base.String putDoc :: DocLoc -> GHC.Internal.Base.String -> Q () - putQ :: forall a. ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () + putQ :: forall a. ghc-internal-10.100.0:GHC.Internal.Data.Typeable.Internal.Typeable a => a -> Q () recover :: forall a. Q a -> Q a -> Q a reify :: Name -> Q Info reifyAnnotations :: forall a. GHC.Internal.Data.Data.Data a => AnnLookup -> Q [a] @@ -1884,6 +1883,7 @@ module Language.Haskell.TH.Syntax where trueName :: Name tupleDataName :: GHC.Internal.Types.Int -> Name tupleTypeName :: GHC.Internal.Types.Int -> Name + unQ :: forall a. Q a -> forall (m :: * -> *). Quasi m => m a unTypeCode :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => Code m a -> m Exp unTypeQ :: forall (r :: GHC.Internal.Types.RuntimeRep) (a :: TYPE r) (m :: * -> *). Quote m => m (TExp a) -> m Exp unboxedSumDataName :: SumAlt -> SumArity -> Name @@ -2289,10 +2289,10 @@ instance forall a b c d e f g. (GHC.Internal.TH.Lift.Lift a, GHC.Internal.TH.Lif instance GHC.Internal.TH.Lift.Lift (# #) -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Char# -- Defined in ‘GHC.Internal.TH.Lift’ instance GHC.Internal.TH.Lift.Lift GHC.Internal.Prim.Word# -- Defined in ‘GHC.Internal.TH.Lift’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ -instance GHC.Internal.TH.Monad.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.TH.Monad’ instance GHC.Internal.TH.Monad.Quote GHC.Internal.TH.Monad.Q -- Defined in ‘GHC.Internal.TH.Monad’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.BndrVis -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag GHC.Internal.TH.Syntax.Specificity -- Defined in ‘Language.Haskell.TH.Lib’ instance [safe] Language.Haskell.TH.Lib.DefaultBndrFlag () -- Defined in ‘Language.Haskell.TH.Lib’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.Types.IO -- Defined in ‘Language.Haskell.TH.Syntax’ +instance Language.Haskell.TH.Syntax.Quasi GHC.Internal.TH.Monad.Q -- Defined in ‘Language.Haskell.TH.Syntax’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44cc53feef363e4beeb5f3d70e008a6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/44cc53feef363e4beeb5f3d70e008a6… You're receiving this email because of your account on gitlab.haskell.org.

1 0