- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/backports-9.12.4] 20 commits: Evaluate backtraces for "error" exceptions at the moment they are thrown
by Zubin (＠wz1000) 03 Mar '26

03 Mar '26

Zubin pushed to branch wip/backports-9.12.4 at Glasgow Haskell Compiler / GHC Commits: a3f7ffef by Matthew Pickering at 2026-03-03T10:49:47+05:30 Evaluate backtraces for "error" exceptions at the moment they are thrown See Note [Capturing the backtrace in throw] and Note [Hiding precise exception signature in throw] which explain the implementation. This commit makes `error` and `throw` behave the same with regard to backtraces. Previously, exceptions raised by `error` would not contain useful IPE backtraces. I did try and implement `error` in terms of `throw` but it started to involve putting diverging functions into hs-boot files, which seemed to risky if the compiler wouldn't be able to see if applying a function would diverge. CLC proposal: https://github.com/haskell/core-libraries-committee/issues/383 Fixes #26751 (cherry picked from commit 94dcd15e54146abecf9b4f5e47d258ca3cd40f1b) - - - - - 5839b832 by fendor at 2026-03-03T10:49:47+05:30 Remove `traceId` from ghc-pkg executable (cherry picked from commit d0966e64880e9fa30ce07c0fa5ea28108c6e8ad9) - - - - - 79bc27f8 by sheaf at 2026-03-03T10:49:47+05:30 Don't re-use stack slots for growing registers This commit avoids re-using a stack slot for a register that has grown but already had a stack slot. For example, suppose we have stack slot assigments %v1 :: FF64 |-> StackSlot 0 %v2 :: FF64 |-> StackSlot 1 Later, we start using %v1 at a larger format (e.g. F64x2) and we need to spill it again. Then we **must not** use StackSlot 0, as a spill at format F64x2 would clobber the data in StackSlot 1. This can cause some fragmentation of the `StackMap`, but that's probably OK. Fixes #26668 (cherry picked from commit 023c301c51e7346af3d4d773c448277ad3645ad2) - - - - - 8e964b00 by Cheng Shao at 2026-03-03T10:49:47+05:30 llvm: fix split sections for llvm backend This patch fixes split sections for llvm backend: - Pass missing `--data-sections`/`--function-sections` flags to llc/opt. - Use `@llvm.compiler.used` instead of `@llvm.used` to avoid sections being unnecessarily retained at link-time. Fixes #26770. ------------------------- Metric Decrease: libdir size_hello_artifact size_hello_unicode ------------------------- Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit b18b2c42c32488ad6d3480a56a1fcd753cad2023) - - - - - e9f0c76e by Matthew Pickering at 2026-03-03T10:49:47+05:30 Fix ghc-experimental GHC.Exception.Backtrace.Experimental module This module wasn't added to the cabal file so it was never compiled or included in the library. (cherry picked from commit ee937134aa0ddf35c1a9dc7334c0aec0de13b719) - - - - - 43715212 by Sylvain Henry at 2026-03-03T10:49:47+05:30 GC: don't use CAS without PARALLEL_GC on If we're not using the parallel GC, there is no reason to do a costly CAS. This was flagged as taking time in a perf profile. (cherry picked from commit 0491f08a965df0d6448bd9cd940d2b86fca2db5d) - - - - - e98afd59 by Sylvain Henry at 2026-03-03T10:49:48+05:30 GC: suffix parallel GC with "par" instead of "thr" Avoid some potential confusion (see discussion in !15351). (cherry picked from commit 211a8f5633f0a5069c0689171f60b57719a242be) - - - - - 8aea6d74 by Cheng Shao at 2026-03-03T10:49:48+05:30 testsuite: avoid re.sub in favor of simple string replacements This patch refactors the testsuite driver and avoids the usage of re.sub in favor of simple string replacements when possible. The changes are not comprehensive, and there are still a lot of re.sub usages lingering around the tree, but this already addresses a major performance bottleneck in the testsuite driver that might has to do with quadratic or worse slowdown in cpython's regular expression engine when handling certain regex patterns with large strings. Especially on i386, and i386 jobs are the bottlenecks of all full-ci validate pipelines! Here are the elapsed times of testing x86_64/i386 with -j48 before this patch: x86_64: `Build completed in 6m06s` i386: `Build completed in 1h36m` And with this patch: x86_64: `Build completed in 4m55s` i386: `Build completed in 4m23s` Fixes #26786. Co-authored-by: Codex <codex(a)openai.com> (cherry picked from commit ca79475f6b4dfba991e2c933bac9c22d54a4950d) - - - - - 22e6dda8 by Zubin Duggal at 2026-03-03T10:49:48+05:30 hadrian: Add ghc-{experimental,internal}.cabal to the list of dependencies of the doc target We need these files to detect the version of these libraries Fixes #26738 (cherry picked from commit 1b490f5a7bbdb1441948241e6089b31efba9db45) - - - - - c2322fcc by Jessica Clarke at 2026-03-03T10:49:48+05:30 PPC NCG: Use libcall for 64-bit cmpxchg on 32-bit PowerPC There is no native instruction for this, and even if there were a register pair version we could use, the implementation here is assuming the values fit in a single register, and we end up only using / defining the low halves of the registers. Fixes: b4d39adbb5 ("PrimOps: Add CAS op for all int sizes") Fixes: #23969 (cherry picked from commit ce2d62fba69d2ea0c74c46c50628feb8b81719d2) - - - - - 546506f5 by John Paul Adrian Glaubitz at 2026-03-03T10:49:48+05:30 rts: Switch prim to use modern atomic compiler builtins The __sync_*() atomic compiler builtins have been deprecated in GCC for a while now and also don't provide variants for 64-bit values such as __sync_fetch_and_add_8(). Thus, replace them with the modern __atomic_*() compiler builtins and while we're at it, also drop the helper macro CAS_NAND() which is now no longer needed since we stopped using the __sync_*() compiler builtins altogether. Co-authored-by: Ilias Tsitsimpis <iliastsi(a)debian.org> Fixes #26729 (cherry picked from commit 7c52c4f9bc8d6ae6404039ec02efe48fbf7a4778) - - - - - 1b75850a by sterni at 2026-03-03T10:49:48+05:30 users_guide: fix runtime error during build with Sphinx 9.1.0 Appears that pathto is stricter about what it accepts now. Tested Sphinx 8.2.3 and 9.1.0 on the ghc-9.10 branch. Resolves #26810. Co-authored-by: Martin Weinelt <hexa(a)darmstadt.ccc.de> (cherry picked from commit e8f5a45de561ec80c88cd3da2c66502deb32d4c3) - - - - - 8103c4f4 by Michael Karcher at 2026-03-03T10:49:48+05:30 NCG for PPC: add pattern for CmmRegOff to iselExpr64 Closes #26828 (cherry picked from commit 43d977619de65c0cf87695fa5d86f1a3ff3176c3) - - - - - 777a7b5a by Matthew Pickering at 2026-03-03T10:49:48+05:30 determinism: Use deterministic map for Strings in TyLitMap When generating typeable evidence the types we need evidence for all cached in a TypeMap, the order terms are retrieved from a type map determines the order the bindings appear in the program. A TypeMap is quite diligent to use deterministic maps, apart from in the TyLitMap, which uses a UniqFM for storing strings, whose ordering depends on the Unique of the FastString. This can cause non-deterministic .hi and .o files. An unexpected side-effect is the error message but RecordDotSyntaxFail8 changing. I looked into this with Sam and this change caused the constraints to be solved in a different order which results in a slightly different error message. I have accepted the new test, since the output before was non-deterministic and the new output is consistent with the other messages in that file. Fixes #26846 (cherry picked from commit aeeb4a2034e80e26503eb88f5abde85e87a82f7b) - - - - - 293ded1d by Andrew Lelechenko at 2026-03-03T10:49:48+05:30 Upgrade text submodule to 2.1.4 (cherry picked from commit 9e4d70c2764d117c5cf753127f93056d66e4f0d7) - - - - - bced716b by Zubin Duggal at 2026-03-03T10:49:48+05:30 Bump transformers submodule to 0.6.3.0 Fixes #26790 (cherry picked from commit ea0d1317a630799a6b7bea12b24ef7e1ea6ed512) - - - - - 5e9a99fb by Matthew Pickering at 2026-03-03T10:49:48+05:30 determinism: Use a stable sort in WithHsDocIdentifiers binary instance `WithHsDocIdentifiers` is defined as ``` 71 data WithHsDocIdentifiers a pass = WithHsDocIdentifiers 72 { hsDocString :: !a 73 , hsDocIdentifiers :: ![Located (IdP pass)] 74 } ``` This list of names is populated from `rnHsDocIdentifiers`, which calls `lookupGRE`, which calls `lookupOccEnv_AllNameSpaces`, which calls `nonDetEltsUFM` and returns the results in an order depending on uniques. Sorting the list with a stable sort before returning the interface makes the output deterministic and follows the approach taken by other fields in `Docs`. Fixes #26858 (cherry picked from commit 0020e38a021b5f0371c48fe73cddf8987acb1eb1) - - - - - f6e481a3 by Simon Peyton Jones at 2026-03-03T10:49:48+05:30 Fix subtle bug in cast worker/wrapper See (CWw4) in Note [Cast worker/wrapper]. The true payload is in the change to the definition of GHC.Types.Id.Info.hasInlineUnfolding Everthing else is just documentation. There is a 2% compile time decrease for T13056; I'll take the win! Metric Decrease: T13056 (cherry picked from commit 99d8c146c12146e1e21b1f2d31809845d4afe9d4) - - - - - 39783f42 by Cheng Shao at 2026-03-03T10:49:48+05:30 wasm: use import.meta.main for proper distinction of nodejs main modules This patch uses `import.meta.main` for proper distinction of nodejs main modules, especially when the main module might be installed as a symlink. Fixes #26916. (cherry picked from commit 039f19778e35b193af0de2a2c6ed89556038627a) - - - - - 519601bc by Zubin Duggal at 2026-03-03T10:49:48+05:30 Prepare release 9.12.4 - - - - - 49 changed files: - compiler/GHC/CmmToAsm/PPC/CodeGen.hs - compiler/GHC/CmmToAsm/Reg/Linear.hs - compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs - compiler/GHC/CmmToLlvm.hs - compiler/GHC/CmmToLlvm/Base.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Types/Id/Info.hs - docs/users_guide/release-notes.rst - docs/users_guide/rtd-theme/layout.html - hadrian/src/Rules/Documentation.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - libraries/ghc-experimental/ghc-experimental.cabal.in - libraries/ghc-experimental/src/GHC/Exception/Backtrace/Experimental.hs - libraries/ghc-internal/src/GHC/Internal/Err.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.hs - + libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout - libraries/text - libraries/transformers - rts/prim/atomic.c - rts/rts.cabal - rts/sm/Evac.c - rts/sm/Evac_thr.c → rts/sm/Evac_par.c - rts/sm/Scav_thr.c → rts/sm/Scav_par.c - testsuite/driver/runtests.py - testsuite/driver/testlib.py - testsuite/driver/testutil.py - + testsuite/tests/ghc-api/TypeMapStringLiteral.hs - testsuite/tests/ghc-api/all.T - testsuite/tests/ghci.debugger/scripts/T8487.stdout - testsuite/tests/ghci.debugger/scripts/break011.stdout - testsuite/tests/ghci.debugger/scripts/break017.stdout - testsuite/tests/ghci.debugger/scripts/break025.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - + testsuite/tests/simplCore/should_compile/T26903.hs - + testsuite/tests/simplCore/should_compile/T26903.stderr - testsuite/tests/simplCore/should_compile/all.T - utils/ghc-pkg/Main.hs - utils/jsffi/dyld.mjs - utils/jsffi/post-link.mjs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45bc79ab3c196a90297cad2368983d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/45bc79ab3c196a90297cad2368983d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/io-manager-deadlock-detection] Deleted 5 commits: Make the IOManager API use CapIOManager rather than Capability
by Duncan Coutts (＠dcoutts) 03 Mar '26

03 Mar '26

Duncan Coutts pushed to branch wip/io-manager-deadlock-detection at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: f340f464 by Duncan Coutts at 2026-02-11T22:48:35+00:00 Make the IOManager API use CapIOManager rather than Capability This makes the API somewhat more self-contained and more consistent. Now the IOManager API and each of the backends takes just the I/O manager structure. Previously we had a bit of a mixture, depending on whether the function needed access to the Capability or just the CapIOManager. We still need access to the cap, so we introduce a back reference to reach the capability, via iomgr->cap. Convert all uses in select and poll backends, but not win32 ones. Convert callers in the scheduler and elsewhere. Also convert the three CMM primops that call IOManager APIs. They just need to use Capability_iomgr(MyCapability()). - - - - - 1136fd5b by Duncan Coutts at 2026-02-16T00:30:48+00:00 Split posix/MIO.c out of posix/Signals.c The MIO I/O manager was secretly living inside the Signals file. Now it gets its own file, like any other self-respecting I/O manager. - - - - - ec170e68 by Duncan Coutts at 2026-02-16T00:30:50+00:00 Rationalise some scheduler run queue utilities Move them all to the same place in the file. Make some static that were used only internally. Also remove a redundant assignment after calling truncateRunQueue that is already done within truncateRunQueue. - - - - - c4312136 by Duncan Coutts at 2026-02-16T00:30:50+00:00 Rename initIOManager{AfterFork} to {re}startIOManager These are more accurate names, since these actions happen after initialisation and are really about starting (or restarting) background threads. - - - - - 24a403ed by Duncan Coutts at 2026-02-16T00:30:50+00:00 Add a TODO to the MIO I/O manager The direction of travel is to make I/O managers per-capability and have all their state live in the struct CapIOManager. The MIO I/O manager however still has a number of global variables. It's not obvious how handle these globals however. - - - - - 20 changed files: - rts/Capability.c - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/RtsStartup.c - rts/Schedule.c - rts/Schedule.h - + rts/posix/MIO.c - + rts/posix/MIO.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - rts/posix/Select.h - rts/posix/Signals.c - rts/posix/Signals.h - rts/posix/Timeout.c - rts/posix/Timeout.h - rts/rts.cabal Changes: ===================================== rts/Capability.c ===================================== @@ -286,7 +286,8 @@ initCapability (Capability *cap, uint32_t i) #endif cap->total_allocated = 0; - initCapabilityIOManager(cap); /* initialises cap->iomgr */ + cap->iomgr = allocCapabilityIOManager(cap); + initCapabilityIOManager(cap->iomgr); cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info; cap->f.stgGCEnter1 = (StgFunPtr)__stg_gc_enter_1; @@ -1344,7 +1345,7 @@ markCapability (evac_fn evac, void *user, Capability *cap, } #endif - markCapabilityIOManager(evac, user, cap); + markCapabilityIOManager(evac, user, cap->iomgr); // Free STM structures for this Capability stmPreGCHook(cap); ===================================== rts/IOManager.c ===================================== @@ -39,7 +39,7 @@ #endif #if defined(IOMGR_ENABLED_MIO_POSIX) -#include "posix/Signals.h" +#include "posix/MIO.h" #include "Prelude.h" #endif @@ -316,22 +316,29 @@ char * showIOManager(void) } } +/* Allocate a CapIOManager for a given Capability. Having this helps us keep + * struct CapIOManager opaque from most of the rest of the RTS. + */ +CapIOManager *allocCapabilityIOManager(Capability *cap) +{ + CapIOManager *iomgr = stgMallocBytes(sizeof(CapIOManager), + "allocCapabilityIOManager"); + iomgr->cap = cap; /* link back */ + return iomgr; +} + -/* Allocate and initialise the per-capability CapIOManager that lives in each - * Capability. Called from initCapability(), which is done in the RTS startup - * in initCapabilities(), and later at runtime via setNumCapabilities(). +/* Initialise the per-capability CapIOManager that lives in each Capability. + * Called from initCapability(), which is done in the RTS startup in + * initCapabilities(), and later at runtime via setNumCapabilities(). * * Note that during RTS startup this is called _before_ the storage manager * is initialised, so this is not allowed to allocate on the GC heap. */ -void initCapabilityIOManager(Capability *cap) +void initCapabilityIOManager(CapIOManager *iomgr) { debugTrace(DEBUG_iomanager, "initialising I/O manager %s for cap %d", - showIOManager(), cap->no); - - CapIOManager *iomgr = - (CapIOManager *) stgMallocBytes(sizeof(CapIOManager), - "initCapabilityIOManager"); + showIOManager(), iomgr->cap->no); switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) @@ -363,16 +370,14 @@ void initCapabilityIOManager(Capability *cap) default: break; } - - cap->iomgr = iomgr; } /* Called late in the RTS initialisation */ -void initIOManager(void) +void startIOManager(void) { - debugTrace(DEBUG_iomanager, "initialising %s I/O manager", showIOManager()); + debugTrace(DEBUG_iomanager, "starting %s I/O manager", showIOManager()); switch (iomgr_type) { @@ -436,7 +441,7 @@ void initIOManager(void) /* Called from forkProcess in the child process on the surviving capability. */ void -initIOManagerAfterFork(Capability **pcap) +restartIOManager(CapIOManager *iomgr, Capability **pcap) { switch (iomgr_type) { @@ -467,7 +472,7 @@ initIOManagerAfterFork(Capability **pcap) /* Called from setNumCapabilities. */ -void notifyIOManagerCapabilitiesChanged(Capability **pcap) +void notifyIOManagerCapabilitiesChanged(CapIOManager *iomgr, Capability **pcap) { switch (iomgr_type) { #if defined(IOMGR_ENABLED_MIO_POSIX) @@ -572,38 +577,29 @@ void wakeupIOManager(void) } } -void markCapabilityIOManager(evac_fn evac, void *user, Capability *cap) +void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr) { switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - { - CapIOManager *iomgr = cap->iomgr; evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_hd); evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_tl); evac(user, (StgClosure **)(void *)&iomgr->sleeping_queue); break; - } #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - { - CapIOManager *iomgr = cap->iomgr; markClosureTable(evac, user, &iomgr->aiop_table); evac(user, (StgClosure **)(void *)&iomgr->timeout_queue); break; - } #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) case IO_MANAGER_WIN32_LEGACY: - { - CapIOManager *iomgr = cap->iomgr; evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_hd); evac(user, (StgClosure **)(void *)&iomgr->blocked_queue_tl); break; - } #endif default: break; @@ -665,29 +661,23 @@ setIOManagerControlFd(uint32_t cap_no, int fd) { #endif -bool anyPendingTimeoutsOrIO(Capability *cap) +bool anyPendingTimeoutsOrIO(CapIOManager *iomgr) { switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - { - CapIOManager *iomgr = cap->iomgr; return (iomgr->blocked_queue_hd != END_TSO_QUEUE) || (iomgr->sleeping_queue != END_TSO_QUEUE); - } #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - return anyPendingTimeoutsOrIOPoll(cap->iomgr); + return anyPendingTimeoutsOrIOPoll(iomgr); #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) case IO_MANAGER_WIN32_LEGACY: - { - CapIOManager *iomgr = cap->iomgr; return (iomgr->blocked_queue_hd != END_TSO_QUEUE); - } #endif /* For the purpose of the scheduler, the threaded I/O managers never have @@ -729,19 +719,19 @@ bool anyPendingTimeoutsOrIO(Capability *cap) } -void pollCompletedTimeoutsOrIO(Capability *cap) +void pollCompletedTimeoutsOrIO(CapIOManager *iomgr) { debugTrace(DEBUG_iomanager, "polling for completed IO or timeouts"); switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - awaitCompletedTimeoutsOrIOSelect(cap, false); + awaitCompletedTimeoutsOrIOSelect(iomgr, false); break; #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - pollCompletedTimeoutsOrIOPoll(cap); + pollCompletedTimeoutsOrIOPoll(iomgr); break; #endif @@ -753,7 +743,7 @@ void pollCompletedTimeoutsOrIO(Capability *cap) #if defined(IOMGR_ENABLED_WINIO) case IO_MANAGER_WINIO: #endif - awaitCompletedTimeoutsOrIOWin32(cap, false); + awaitCompletedTimeoutsOrIOWin32(iomgr->cap, false); break; #endif default: @@ -762,19 +752,19 @@ void pollCompletedTimeoutsOrIO(Capability *cap) } -void awaitCompletedTimeoutsOrIO(Capability *cap) +void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr) { debugTrace(DEBUG_iomanager, "waiting for completed IO or timeouts"); switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - awaitCompletedTimeoutsOrIOSelect(cap, true); + awaitCompletedTimeoutsOrIOSelect(iomgr, true); break; #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - awaitCompletedTimeoutsOrIOPoll(cap); + awaitCompletedTimeoutsOrIOPoll(iomgr); break; #endif @@ -786,17 +776,18 @@ void awaitCompletedTimeoutsOrIO(Capability *cap) #if defined(IOMGR_ENABLED_WINIO) case IO_MANAGER_WINIO: #endif - awaitCompletedTimeoutsOrIOWin32(cap, true); + awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true); break; #endif default: barf("pollCompletedTimeoutsOrIO not implemented"); } - ASSERT(!emptyRunQueue(cap) || getSchedState() != SCHED_RUNNING); + ASSERT(!emptyRunQueue(iomgr->cap) || getSchedState() != SCHED_RUNNING); } -bool syncIOWaitReady(Capability *cap, +/* CMM primop. Result is true on success, or false on allocation failure. */ +bool syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd) @@ -812,14 +803,14 @@ bool syncIOWaitReady(Capability *cap, StgWord why_blocked = rw == IORead ? BlockedOnRead : BlockedOnWrite; tso->block_info.fd = fd; RELEASE_STORE(&tso->why_blocked, why_blocked); - appendToIOBlockedQueue(cap, tso); + appendToIOBlockedQueue(iomgr, tso); return true; } #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: ASSERT(tso->why_blocked == NotBlocked); - return syncIOWaitReadyPoll(cap, tso, rw, fd); + return syncIOWaitReadyPoll(iomgr, tso, rw, fd); #endif default: barf("waitRead# / waitWrite# not available for current I/O manager"); @@ -827,25 +818,29 @@ bool syncIOWaitReady(Capability *cap, } -void syncIOCancel(Capability *cap, StgTSO *tso) +void syncIOCancel(CapIOManager *iomgr, StgTSO *tso) { debugTrace(DEBUG_iomanager, "cancelling I/O for thread %ld", (long) tso->id); switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - removeThreadFromDeQueue(cap, &cap->iomgr->blocked_queue_hd, - &cap->iomgr->blocked_queue_tl, tso); + removeThreadFromDeQueue(iomgr->cap, + &iomgr->blocked_queue_hd, + &iomgr->blocked_queue_tl, + tso); break; #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - syncIOCancelPoll(cap, tso); + syncIOCancelPoll(iomgr, tso); break; #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) case IO_MANAGER_WIN32_LEGACY: - removeThreadFromDeQueue(cap, &cap->iomgr->blocked_queue_hd, - &cap->iomgr->blocked_queue_tl, tso); + removeThreadFromDeQueue(iomgr->cap, + &iomgr->blocked_queue_hd, + &iomgr->blocked_queue_tl, + tso); abandonWorkRequest(tso->block_info.async_result->reqID); break; #endif @@ -856,11 +851,12 @@ void syncIOCancel(Capability *cap, StgTSO *tso) #if defined(IOMGR_ENABLED_SELECT) -static void insertIntoSleepingQueue(Capability *cap, StgTSO *tso, LowResTime target); +static void insertIntoSleepingQueue(CapIOManager *iomgr, StgTSO *tso, LowResTime target); #endif -bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay) +/* CMM primop. Result is true on success, or false on allocation failure. */ +bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay) { debugTrace(DEBUG_iomanager, "thread %ld waiting for %lld us", tso->id, us_delay); ASSERT(tso->why_blocked == NotBlocked); @@ -871,13 +867,13 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay) LowResTime target = getDelayTarget(us_delay); tso->block_info.target = target; RELEASE_STORE(&tso->why_blocked, BlockedOnDelay); - insertIntoSleepingQueue(cap, tso, target); + insertIntoSleepingQueue(iomgr, tso, target); return true; } #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - return syncDelayTimeout(cap, tso, us_delay); + return syncDelayTimeout(iomgr, tso, us_delay); #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) case IO_MANAGER_WIN32_LEGACY: @@ -897,7 +893,7 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay) * delayed thread on the blocked_queue. */ RELEASE_STORE(&tso->why_blocked, BlockedOnDoProc); - appendToIOBlockedQueue(cap, tso); + appendToIOBlockedQueue(iomgr, tso); return true; } #endif @@ -907,18 +903,18 @@ bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay) } -void syncDelayCancel(Capability *cap, StgTSO *tso) +void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso) { debugTrace(DEBUG_iomanager, "cancelling delay for thread %ld", (long) tso->id); switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - removeThreadFromQueue(cap, &cap->iomgr->sleeping_queue, tso); + removeThreadFromQueue(iomgr->cap, &iomgr->sleeping_queue, tso); break; #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - syncDelayCancelTimeout(cap, tso); + syncDelayCancelTimeout(iomgr, tso); break; #endif /* Note: no case for IO_MANAGER_WIN32_LEGACY despite it having a case @@ -935,14 +931,13 @@ void syncDelayCancel(Capability *cap, StgTSO *tso) #if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_WIN32_LEGACY) -void appendToIOBlockedQueue(Capability *cap, StgTSO *tso) +void appendToIOBlockedQueue(CapIOManager *iomgr, StgTSO *tso) { - CapIOManager *iomgr = cap->iomgr; ASSERT(tso->_link == END_TSO_QUEUE); if (iomgr->blocked_queue_hd == END_TSO_QUEUE) { iomgr->blocked_queue_hd = tso; } else { - setTSOLink(cap, iomgr->blocked_queue_tl, tso); + setTSOLink(iomgr->cap, iomgr->blocked_queue_tl, tso); } iomgr->blocked_queue_tl = tso; } @@ -957,9 +952,8 @@ void appendToIOBlockedQueue(Capability *cap, StgTSO *tso) * used. This is a wart that should be excised. */ // TODO: move to Select.c and rename -static void insertIntoSleepingQueue(Capability *cap, StgTSO *tso, LowResTime target) +static void insertIntoSleepingQueue(CapIOManager *iomgr, StgTSO *tso, LowResTime target) { - CapIOManager *iomgr = cap->iomgr; StgTSO *prev = NULL; StgTSO *t = iomgr->sleeping_queue; while (t != END_TSO_QUEUE && t->block_info.target < target) { @@ -971,7 +965,7 @@ static void insertIntoSleepingQueue(Capability *cap, StgTSO *tso, LowResTime tar if (prev == NULL) { iomgr->sleeping_queue = tso; } else { - setTSOLink(cap, prev, tso); + setTSOLink(iomgr->cap, prev, tso); } } #endif ===================================== rts/IOManager.h ===================================== @@ -19,6 +19,7 @@ #pragma once +#include "Capability.h" #include "sm/GC.h" // for evac_fn #include "BeginPrivate.h" @@ -227,26 +228,35 @@ enum IOOpOutcome { void selectIOManager(void); -/* Allocate and initialise the per-capability CapIOManager that lives in each - * Capability. Called from initCapability(), which is done in the RTS startup - * in initCapabilities(), and later at runtime via setNumCapabilities(). +/* Allocate a CapIOManager for a given Capability. Having this helps us keep + * struct CapIOManager opaque from most of the rest of the RTS. */ -void initCapabilityIOManager(Capability *cap); +CapIOManager *allocCapabilityIOManager(Capability *cap); + +/* Initialise the per-capability CapIOManager that lives in each Capability. + * Called from initCapability(), which is done in the RTS startup in + * initCapabilities(), and later at runtime via setNumCapabilities(). + * + * This is separate from allocCapabilityIOManager so that we can re-initialise + * I/O managers after forkProcess. + */ +void initCapabilityIOManager(CapIOManager *iomgr); /* Init hook: called from hs_init_ghc, very late in the startup after almost * everything else is done. */ -void initIOManager(void); +void startIOManager(void); /* Init hook: called from forkProcess in the child process on the surviving * capability. * - * Note that this is synchronous and can run Haskell code, so can change the - * given cap. + * This is synchronous and can run Haskell code, so can change the given cap. + * TODO: it would make for a cleaner API here if this were made asynchronous. */ -void initIOManagerAfterFork(/* inout */ Capability **pcap); +void restartIOManager(CapIOManager *iomgr, + /* inout */ Capability **pcap); /* TODO: rationalise initIOManager and initIOManagerAfterFork into a single per-capability init function. @@ -254,8 +264,12 @@ void initIOManagerAfterFork(/* inout */ Capability **pcap); /* Called from setNumCapabilities. + * + * This is synchronous and can run Haskell code, so can change the given cap. + * TODO: it would make for a cleaner API here if this were made asynchronous. */ -void notifyIOManagerCapabilitiesChanged(Capability **pcap); +void notifyIOManagerCapabilitiesChanged(CapIOManager *iomgr, + /* inout */ Capability **pcap); /* Shutdown hooks: called from hs_exit_ before and after the scheduler exits. @@ -288,7 +302,7 @@ void wakeupIOManager(void); /* GC hook: mark any per-capability GC roots the I/O manager uses. */ -void markCapabilityIOManager(evac_fn evac, void *user, Capability *cap); +void markCapabilityIOManager(evac_fn evac, void *user, CapIOManager *iomgr); /* GC hook: scavenge I/O related tso->block_info. Used by scavengeTSO. @@ -305,21 +319,20 @@ typedef enum { IORead, IOWrite } IOReadOrWrite; * necessarily operate on threads. The thread is suspended until the operation * completes. * - * These are called from CMM primops. The ones returing int can perform heap - * allocation, which might fail. They return 0 on success, or n > 0 on heap - * allocation failure, needing n words. The CMM primops should invoke the - * GC to free up at least n words and then retry the operation. + * Some of these are called from CMM primops. The primops returing bool can + * perform heap allocation, which might fail. They return true on success, or + * false on heap allocation failure. */ -/* Result is true on success, or false on allocation failure. */ -bool syncIOWaitReady(Capability *cap, StgTSO *tso, IOReadOrWrite rw, HsInt fd); +/* Called from CMM primop */ +bool syncIOWaitReady(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd); -void syncIOCancel(Capability *cap, StgTSO *tso); +void syncIOCancel(CapIOManager *iomgr, StgTSO *tso); -/* Result is true on success, or false on allocation failure. */ -bool syncDelay(Capability *cap, StgTSO *tso, HsInt us_delay); +/* Called from CMM primop */ +bool syncDelay(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay); -void syncDelayCancel(Capability *cap, StgTSO *tso); +void syncDelayCancel(CapIOManager *iomgr, StgTSO *tso); #if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_WIN32_LEGACY) /* Add a thread to the end of the queue of threads blocked on I/O. @@ -327,7 +340,7 @@ void syncDelayCancel(Capability *cap, StgTSO *tso); * This is used by the select() and the Windows MIO non-threaded I/O manager * implementation. Called from CMM code. */ -void appendToIOBlockedQueue(Capability *cap, StgTSO *tso); +void appendToIOBlockedQueue(CapIOManager *iomgr, StgTSO *tso); #endif /* Check to see if there are any pending timeouts or I/O operations @@ -336,7 +349,7 @@ void appendToIOBlockedQueue(Capability *cap, StgTSO *tso); * This is used by the scheduler as part of deadlock-detection, and the * "context switch as often as possible" test. */ -bool anyPendingTimeoutsOrIO(Capability *cap); +bool anyPendingTimeoutsOrIO(CapIOManager *iomgr); /* If there are any completed I/O operations or expired timers, process the * completions as appropriate (which will typically unblock some waiting @@ -344,7 +357,7 @@ bool anyPendingTimeoutsOrIO(Capability *cap); * * Called from schedule() both *before* and *after* scheduleDetectDeadlock(). */ -void pollCompletedTimeoutsOrIO(Capability *cap); +void pollCompletedTimeoutsOrIO(CapIOManager *iomgr); /* If there are any completed I/O operations or expired timers, process the * completions as appropriate. If there are none, wait until I/O or a timer @@ -360,6 +373,6 @@ void pollCompletedTimeoutsOrIO(Capability *cap); * * Called from schedule() both *before* and *after* scheduleDetectDeadlock(). */ -void awaitCompletedTimeoutsOrIO(Capability *cap); +void awaitCompletedTimeoutsOrIO(CapIOManager *iomgr); #include "EndPrivate.h" ===================================== rts/IOManagerInternals.h ===================================== @@ -24,7 +24,8 @@ /* The per-capability data structures belonging to the I/O manager. * - * It can be accessed as cap->iomgr. + * It can be accessed as cap->iomgr. Or given just the iomgr, you can access + * the owning cap as iomgr->cap. * * The content of the structure is defined conditionally so it is different for * each I/O manager implementation. @@ -33,6 +34,9 @@ */ struct _CapIOManager { + /* Back reference to the containing capability */ + Capability *cap; + #if defined(IOMGR_ENABLED_SELECT) /* Thread queue for threads blocked on I/O completion. */ StgTSO *blocked_queue_hd; ===================================== rts/PrimOps.cmm ===================================== @@ -2279,7 +2279,8 @@ stg_waitReadzh ( W_ fd ) { CBool ok; /* Ok, or heap alloc failure. */ - (ok) = ccall syncIOWaitReady(MyCapability() "ptr", CurrentTSO "ptr", + (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr", + CurrentTSO "ptr", /* IORead */ 0::I32, fd); if (ok != 0::CBool) (likely: True) { jump stg_block_noregs(); @@ -2292,7 +2293,8 @@ stg_waitWritezh ( W_ fd ) { CBool ok; /* Ok, or heap alloc failure. */ - (ok) = ccall syncIOWaitReady(MyCapability() "ptr", CurrentTSO "ptr", + (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr", + CurrentTSO "ptr", /* IOWrite */ 1::I32, fd); if (ok != 0::CBool) (likely: True) { jump stg_block_noregs(); @@ -2305,7 +2307,8 @@ stg_delayzh ( W_ us_delay ) { CBool ok; /* Ok, or heap alloc failure. */ - (ok) = ccall syncDelay(MyCapability() "ptr", CurrentTSO "ptr", us_delay); + (ok) = ccall syncDelay(Capability_iomgr(MyCapability()) "ptr", + CurrentTSO "ptr", us_delay); if (ok != 0::CBool) (likely: True) { /* Annoyingly, we cannot be consistent with how we wait and resume the ===================================== rts/RaiseAsync.c ===================================== @@ -708,12 +708,12 @@ removeFromQueues(Capability *cap, StgTSO *tso) case BlockedOnWrite: case BlockedOnDoProc: // These blocking reasons are only used by some I/O managers - syncIOCancel(cap, tso); + syncIOCancel(cap->iomgr, tso); goto done; case BlockedOnDelay: // This blocking reasons is only used by some I/O managers - syncDelayCancel(cap, tso); + syncDelayCancel(cap->iomgr, tso); goto done; default: ===================================== rts/RtsStartup.c ===================================== @@ -427,7 +427,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) } #endif - initIOManager(); + startIOManager(); x86_init_fpu(); ===================================== rts/Schedule.c ===================================== @@ -174,6 +174,11 @@ static void deleteAllThreads (void); static void deleteThread_(StgTSO *tso); #endif +#if defined(FORKPROCESS_PRIMOP_SUPPORTED) +static void truncateRunQueue(Capability *cap); +#endif +static StgTSO *popRunQueue (Capability *cap); + /* --------------------------------------------------------------------------- Main scheduling loop. @@ -409,7 +414,7 @@ schedule (Capability *initialCapability, Task *task) */ if (RtsFlags.ConcFlags.ctxtSwitchTicks == 0 && (!emptyRunQueue(cap) || - anyPendingTimeoutsOrIO(cap))) { + anyPendingTimeoutsOrIO(cap->iomgr))) { RELAXED_STORE(&cap->context_switch, 1); } @@ -591,38 +596,6 @@ run_thread: } /* end of while() */ } -/* ----------------------------------------------------------------------------- - * Run queue operations - * -------------------------------------------------------------------------- */ - -static void -removeFromRunQueue (Capability *cap, StgTSO *tso) -{ - if (tso->block_info.prev == END_TSO_QUEUE) { - ASSERT(cap->run_queue_hd == tso); - cap->run_queue_hd = tso->_link; - } else { - setTSOLink(cap, tso->block_info.prev, tso->_link); - } - if (tso->_link == END_TSO_QUEUE) { - ASSERT(cap->run_queue_tl == tso); - cap->run_queue_tl = tso->block_info.prev; - } else { - setTSOPrev(cap, tso->_link, tso->block_info.prev); - } - tso->_link = tso->block_info.prev = END_TSO_QUEUE; - cap->n_run_queue--; - - IF_DEBUG(sanity, checkRunQueue(cap)); -} - -void -promoteInRunQueue (Capability *cap, StgTSO *tso) -{ - removeFromRunQueue(cap, tso); - pushOnRunQueue(cap, tso); -} - /* ----------------------------------------------------------------------------- * scheduleFindWork() * @@ -923,14 +896,14 @@ scheduleCheckBlockedThreads(Capability *cap USED_IF_NOT_THREADS) * awaitCompletedTimeoutsOrIO below for the case of !defined(THREADED_RTS) * && defined(mingw32_HOST_OS). */ - if (anyPendingTimeoutsOrIO(cap)) + if (anyPendingTimeoutsOrIO(cap->iomgr)) { if (emptyRunQueue(cap)) { // block and wait - awaitCompletedTimeoutsOrIO(cap); + awaitCompletedTimeoutsOrIO(cap->iomgr); } else { // poll but do not wait - pollCompletedTimeoutsOrIO(cap); + pollCompletedTimeoutsOrIO(cap->iomgr); } } #endif @@ -950,7 +923,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task) * other tasks are waiting for work, we must have a deadlock of * some description. */ - if ( emptyRunQueue(cap) && !anyPendingTimeoutsOrIO(cap) ) + if ( emptyRunQueue(cap) && !anyPendingTimeoutsOrIO(cap->iomgr) ) { #if defined(THREADED_RTS) /* @@ -2191,7 +2164,6 @@ forkProcess(HsStablePtr *entry // bound threads for which the corresponding Task does not // exist. truncateRunQueue(cap); - cap->n_run_queue = 0; // Any suspended C-calling Tasks are no more, their OS threads // don't exist now: @@ -2208,7 +2180,7 @@ forkProcess(HsStablePtr *entry cap->n_returning_tasks = 0; #endif - // Release all caps except 0, we'll use that for starting + // Release all caps except 0, we'll use that for restarting // the IO manager and running the client action below. if (cap->no != 0) { task->cap = cap; @@ -2232,7 +2204,7 @@ forkProcess(HsStablePtr *entry // like startup event, capabilities, process info etc traceTaskCreate(task, cap); - initIOManagerAfterFork(&cap); + restartIOManager(cap->iomgr, &cap); // start timer after the IOManager is initialized // (the idle GC may wake up the IOManager) @@ -2392,7 +2364,7 @@ setNumCapabilities (uint32_t new_n_capabilities USED_IF_THREADS) } // Notify IO manager that the number of capabilities has changed. - notifyIOManagerCapabilitiesChanged(&cap); + notifyIOManagerCapabilitiesChanged(cap->iomgr, &cap); startTimer(); @@ -2997,7 +2969,7 @@ pushOnRunQueue (Capability *cap, StgTSO *tso) cap->n_run_queue++; } -StgTSO *popRunQueue (Capability *cap) +static StgTSO *popRunQueue (Capability *cap) { ASSERT(cap->n_run_queue > 0); StgTSO *t = cap->run_queue_hd; @@ -3017,6 +2989,45 @@ StgTSO *popRunQueue (Capability *cap) return t; } +#if defined(FORKPROCESS_PRIMOP_SUPPORTED) +static void truncateRunQueue(Capability *cap) +{ + // Can only be called by the task owning the capability. + TSAN_ANNOTATE_BENIGN_RACE(&cap->run_queue_hd, "truncateRunQueue"); + TSAN_ANNOTATE_BENIGN_RACE(&cap->run_queue_tl, "truncateRunQueue"); + TSAN_ANNOTATE_BENIGN_RACE(&cap->n_run_queue, "truncateRunQueue"); + cap->run_queue_hd = END_TSO_QUEUE; + cap->run_queue_tl = END_TSO_QUEUE; + cap->n_run_queue = 0; +} +#endif + +static void removeFromRunQueue (Capability *cap, StgTSO *tso) +{ + if (tso->block_info.prev == END_TSO_QUEUE) { + ASSERT(cap->run_queue_hd == tso); + cap->run_queue_hd = tso->_link; + } else { + setTSOLink(cap, tso->block_info.prev, tso->_link); + } + if (tso->_link == END_TSO_QUEUE) { + ASSERT(cap->run_queue_tl == tso); + cap->run_queue_tl = tso->block_info.prev; + } else { + setTSOPrev(cap, tso->_link, tso->block_info.prev); + } + tso->_link = tso->block_info.prev = END_TSO_QUEUE; + cap->n_run_queue--; + + IF_DEBUG(sanity, checkRunQueue(cap)); +} + +void promoteInRunQueue (Capability *cap, StgTSO *tso) +{ + removeFromRunQueue(cap, tso); + pushOnRunQueue(cap, tso); +} + /* ----------------------------------------------------------------------------- raiseExceptionHelper ===================================== rts/Schedule.h ===================================== @@ -164,10 +164,6 @@ void appendToRunQueue (Capability *cap, StgTSO *tso); */ void pushOnRunQueue (Capability *cap, StgTSO *tso); -/* Pop the first thread off the runnable queue. - */ -StgTSO *popRunQueue (Capability *cap); - INLINE_HEADER StgTSO * peekRunQueue (Capability *cap) { @@ -184,18 +180,6 @@ emptyRunQueue(Capability *cap) return cap->n_run_queue == 0; } -INLINE_HEADER void -truncateRunQueue(Capability *cap) -{ - // Can only be called by the task owning the capability. - TSAN_ANNOTATE_BENIGN_RACE(&cap->run_queue_hd, "truncateRunQueue"); - TSAN_ANNOTATE_BENIGN_RACE(&cap->run_queue_tl, "truncateRunQueue"); - TSAN_ANNOTATE_BENIGN_RACE(&cap->n_run_queue, "truncateRunQueue"); - cap->run_queue_hd = END_TSO_QUEUE; - cap->run_queue_tl = END_TSO_QUEUE; - cap->n_run_queue = 0; -} - #endif /* !IN_STG_CODE */ #include "EndPrivate.h" ===================================== rts/posix/MIO.c ===================================== @@ -0,0 +1,163 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2005 + * + * Signal processing / handling. + * + * ---------------------------------------------------------------------------*/ + +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "Schedule.h" +#include "RtsUtils.h" +#include "Prelude.h" +#include "ThreadLabels.h" + +#include "MIO.h" +#include "IOManager.h" +#include "IOManagerInternals.h" + +#if defined(HAVE_ERRNO_H) +# include <errno.h> +#endif + +#include <stdlib.h> +#include <unistd.h> + +// Here's the pipe into which we will send our signals +static int io_manager_wakeup_fd = -1; +static int timer_manager_control_wr_fd = -1; +// TODO: Eliminate these globals. Put then into the CapIOManager, but the +// problem is these are shared across all caps, not per cap. + +#define IO_MANAGER_WAKEUP 0xff +#define IO_MANAGER_DIE 0xfe +#define IO_MANAGER_SYNC 0xfd + +void setTimerManagerControlFd(int fd) { + RELAXED_STORE(&timer_manager_control_wr_fd, fd); +} + +void +setIOManagerWakeupFd (int fd) +{ + // only called when THREADED_RTS, but unconditionally + // compiled here because GHC.Event.Control depends on it. + SEQ_CST_STORE(&io_manager_wakeup_fd, fd); +} + +#if defined(THREADED_RTS) +void timerManagerNotifySignal(int sig, siginfo_t *info) +{ + StgWord8 buf[sizeof(siginfo_t) + 1]; + int r; + + buf[0] = sig; + if (info == NULL) { + // info may be NULL on Solaris (see #3790) + memset(buf+1, 0, sizeof(siginfo_t)); + } else { + memcpy(buf+1, info, sizeof(siginfo_t)); + } + + int timer_control_fd = RELAXED_LOAD(&timer_manager_control_wr_fd); + if (0 <= timer_control_fd) + { + r = write(timer_control_fd, buf, sizeof(siginfo_t)+1); + if (r == -1 && errno == EAGAIN) { + errorBelch("lost signal due to full pipe: %d\n", sig); + } + } + + // If the IO manager hasn't told us what the FD of the write end + // of its pipe is, there's not much we can do here, so just ignore + // the signal.. +} +#endif + + +/* ----------------------------------------------------------------------------- + * Wake up at least one IO or timer manager HS thread. + * -------------------------------------------------------------------------- */ +void +ioManagerWakeup (void) +{ + int r; + const int wakeup_fd = SEQ_CST_LOAD(&io_manager_wakeup_fd); + // Wake up the IO Manager thread by sending a byte down its pipe + if (wakeup_fd >= 0) { +#if defined(HAVE_EVENTFD) + StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP; + r = write(wakeup_fd, (char *) &n, 8); +#else + StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP; + r = write(wakeup_fd, &byte, 1); +#endif + /* N.B. If the TimerManager is shutting down as we run this + * then there is a possibility that our first read of + * io_manager_wakeup_fd is non-negative, but before we get to the + * write the file is closed. If this occurs, io_manager_wakeup_fd + * will be written into with -1 (GHC.Event.Control does this prior + * to closing), so checking this allows us to distinguish this case. + * To ensure we observe the correct ordering, we declare the + * io_manager_wakeup_fd as volatile. + * Since this is not an error condition, we do not print the error + * message in this case. + */ + if (r == -1 && SEQ_CST_LOAD(&io_manager_wakeup_fd) >= 0) { + sysErrorBelch("ioManagerWakeup: write"); + } + } +} + +#if defined(THREADED_RTS) +void +ioManagerDie (void) +{ + StgWord8 byte = (StgWord8)IO_MANAGER_DIE; + uint32_t i; + int r; + + { + // Shut down timer manager + const int fd = RELAXED_LOAD(&timer_manager_control_wr_fd); + if (0 <= fd) { + r = write(fd, &byte, 1); + if (r == -1) { sysErrorBelch("ioManagerDie: write"); } + RELAXED_STORE(&timer_manager_control_wr_fd, -1); + } + } + + { + // Shut down IO managers + for (i=0; i < getNumCapabilities(); i++) { + const int fd = RELAXED_LOAD(&getCapability(i)->iomgr->control_fd); + if (0 <= fd) { + r = write(fd, &byte, 1); + if (r == -1) { sysErrorBelch("ioManagerDie: write"); } + RELAXED_STORE(&getCapability(i)->iomgr->control_fd, -1); + } + } + } +} + +void +ioManagerStartCap (Capability **cap) +{ + rts_evalIO(cap,ensureIOManagerIsRunning_closure,NULL); +} + +void +ioManagerStart (void) +{ + // Make sure the IO manager thread is running + Capability *cap; + if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0 || SEQ_CST_LOAD(&io_manager_wakeup_fd) < 0) { + cap = rts_lock(); + ioManagerStartCap(&cap); + rts_unlock(cap); + } +} +#endif + ===================================== rts/posix/MIO.h ===================================== @@ -0,0 +1,30 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2005 + * + * Signal processing / handling. + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include "IOManager.h" + +#if defined(HAVE_SIGNAL_H) +# include <signal.h> +#endif + +#include "BeginPrivate.h" + +/* Communicating with the IO manager thread (see GHC.Conc). + */ +void ioManagerWakeup (void); +#if defined(THREADED_RTS) +void ioManagerDie (void); +void ioManagerStart (void); +void ioManagerStartCap (/* inout */ Capability **cap); + +void timerManagerNotifySignal(int sig, siginfo_t *info); +#endif + +#include "EndPrivate.h" ===================================== rts/posix/Poll.c ===================================== @@ -120,9 +120,9 @@ also allows the signal mask to be adjusted, but we do not make use of this. ******************************************************************************/ /* Forward declarations */ -static bool enlargeTables(Capability *cap, CapIOManager *iomgr); -static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop); -static void ioCancel(Capability *cap, StgAsyncIOOp *aiop); +static bool enlargeTables(CapIOManager *iomgr); +static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop); +static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop); static void reportPollError(int res, nfds_t nfds) STG_NORETURN; @@ -136,32 +136,31 @@ void initCapabilityIOManagerPoll(CapIOManager *iomgr) /* Used to implement syncIOWaitReady. * Result is true on success, or false on allocation failure. */ -bool syncIOWaitReadyPoll(Capability *cap, StgTSO *tso, +bool syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd) { StgAsyncIOOp *aiop; - aiop = (StgAsyncIOOp *)allocateMightFail(cap, sizeofW(StgAsyncIOOp)); + aiop = (StgAsyncIOOp *)allocateMightFail(iomgr->cap, sizeofW(StgAsyncIOOp)); if (RTS_UNLIKELY(aiop == NULL)) return false; - SET_HDR(aiop, &stg_ASYNCIOOP_info, cap->r.rCCCS); + SET_HDR(aiop, &stg_ASYNCIOOP_info, iomgr->cap->r.rCCCS); aiop->notify.tso = tso; aiop->notify_type = NotifyTSO; aiop->live = &stg_ASYNCIO_LIVE0_closure; tso->why_blocked = rw == IORead ? BlockedOnRead : BlockedOnWrite; tso->block_info.aiop = aiop; - return asyncIOWaitReadyPoll(cap, aiop, rw, fd); + return asyncIOWaitReadyPoll(iomgr, aiop, rw, fd); } /* Result is true on success, or false on allocation failure. */ -bool asyncIOWaitReadyPoll(Capability *cap, StgAsyncIOOp *aiop, +bool asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop, IOReadOrWrite rw, int fd) { - CapIOManager *iomgr = cap->iomgr; if (RTS_UNLIKELY(isFullClosureTable(&iomgr->aiop_table))) { - bool ok = enlargeTables(cap, iomgr); + bool ok = enlargeTables(iomgr); if (RTS_UNLIKELY(!ok)) return false; } - int ix = insertClosureTable(cap, &iomgr->aiop_table, aiop); + int ix = insertClosureTable(iomgr->cap, &iomgr->aiop_table, aiop); /* We use the aiop_table and aiop_poll_table densely. */ ASSERT(ix == sizeClosureTable(&iomgr->aiop_table) - 1); @@ -169,7 +168,7 @@ bool asyncIOWaitReadyPoll(Capability *cap, StgAsyncIOOp *aiop, /* The syncIO wrapper or CMM primop filled in the notify and live fields, * we fill the rest. */ - aiop->capno = cap->no; + aiop->capno = iomgr->cap->no; aiop->index = ix; aiop->outcome = IOOpOutcomeInFlight; @@ -183,12 +182,12 @@ bool asyncIOWaitReadyPoll(Capability *cap, StgAsyncIOOp *aiop, } -void syncIOCancelPoll(Capability *cap, StgTSO *tso) +void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso) { StgAsyncIOOp *aiop = tso->block_info.aiop; ASSERT(aiop->notify_type == NotifyTSO); - ASSERT(indexClosureTable(&cap->iomgr->aiop_table, aiop->index) == aiop); - ioCancel(cap, aiop); + ASSERT(indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop); + ioCancel(iomgr, aiop); /* We cannot use the normal notifyIOCompletion here. We are in the context * of throwTo, interrupting a thread blocked on IO via an async exception. * We don't put the TSO back on the run queue or change the why_blocked @@ -198,7 +197,7 @@ void syncIOCancelPoll(Capability *cap, StgTSO *tso) } -void asyncIOCancelPoll(Capability *cap, StgAsyncIOOp *aiop) +void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop) { /* We can reliably determine if the aiop is still in progress by checking * if the aiop_table still points to this aiop object. This is reliable @@ -206,20 +205,18 @@ void asyncIOCancelPoll(Capability *cap, StgAsyncIOOp *aiop) * is no longer retained by the application. */ ASSERT(aiop->notify_type != NotifyTSO); - if (indexClosureTable(&cap->iomgr->aiop_table, aiop->index) == aiop) { - ioCancel(cap, aiop); - notifyIOCompletion(cap, aiop); + if (indexClosureTable(&iomgr->aiop_table, aiop->index) == aiop) { + ioCancel(iomgr, aiop); + notifyIOCompletion(iomgr, aiop); } } -static void ioCancel(Capability *cap, StgAsyncIOOp *aiop) +static void ioCancel(CapIOManager *iomgr, StgAsyncIOOp *aiop) { - CapIOManager *iomgr = cap->iomgr; - int ix = aiop->index; int ix_from; int ix_to; - removeCompactClosureTable(cap, &iomgr->aiop_table, ix, + removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, ix, &ix_from, &ix_to); if (ix_to != ix_from) { StgAsyncIOOp *aiop_to = indexClosureTable(&iomgr->aiop_table, ix_to); @@ -237,7 +234,7 @@ bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr) } -static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop) +static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop) { ASSERT(aiop->outcome != IOOpOutcomeInFlight); switch (aiop->notify_type) { @@ -251,7 +248,8 @@ static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop) debugTrace(DEBUG_iomanager, "Raising exception in thread %" FMT_StgThreadID " blocked on an invalid fd", tso->id); - raiseAsync(cap, tso, (StgClosure *)blockedOnBadFD_closure, + raiseAsync(iomgr->cap, tso, + (StgClosure *)blockedOnBadFD_closure, false, NULL); break; } else { @@ -262,7 +260,7 @@ static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop) StgTSO *tso = aiop->notify.tso; tso->why_blocked = NotBlocked; tso->_link = END_TSO_QUEUE; - pushOnRunQueue(cap, tso); + pushOnRunQueue(iomgr->cap, tso); } break; } @@ -277,8 +275,7 @@ static void notifyIOCompletion(Capability *cap, StgAsyncIOOp *aiop) } -static void processIOCompletions(Capability *cap, CapIOManager *iomgr, - int ncompletions) +static void processIOCompletions(CapIOManager *iomgr, int ncompletions) { /* The scheme we use with poll is that we have a dense poll table, and a * corresponding table that maps to the closure table index. The poll @@ -320,7 +317,7 @@ static void processIOCompletions(Capability *cap, CapIOManager *iomgr, * apply the same compacting to the aiop_poll_table. */ int ix_from; int ix_to; - removeCompactClosureTable(cap, &iomgr->aiop_table, i, + removeCompactClosureTable(iomgr->cap, &iomgr->aiop_table, i, &ix_from, &ix_to); if (ix_to != ix_from) { StgAsyncIOOp *aiop_to; @@ -329,7 +326,7 @@ static void processIOCompletions(Capability *cap, CapIOManager *iomgr, aiop_poll_table[ix_to] = aiop_poll_table[ix_from]; } - notifyIOCompletion(cap, aiop); + notifyIOCompletion(iomgr, aiop); n--; } else { /* You'd expect incrementing the poll table index to be @@ -343,13 +340,11 @@ static void processIOCompletions(Capability *cap, CapIOManager *iomgr, } -void pollCompletedTimeoutsOrIOPoll(Capability *cap) +void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { - CapIOManager *iomgr = cap->iomgr; - if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) { Time now = getProcessElapsedTime(); - processTimeoutCompletions(cap, now); + processTimeoutCompletions(iomgr, now); } if (!isEmptyClosureTable(&iomgr->aiop_table)) { @@ -379,7 +374,7 @@ void pollCompletedTimeoutsOrIOPoll(Capability *cap) } else if (res > 0) { int ncompletions = res; ASSERT(ncompletions <= (int)nfds); - processIOCompletions(cap, iomgr, ncompletions); + processIOCompletions(iomgr, ncompletions); } else if (errno == EINTR) { /* We got interrupted by a signal. This is unlikely since we asked @@ -393,10 +388,8 @@ void pollCompletedTimeoutsOrIOPoll(Capability *cap) } -void awaitCompletedTimeoutsOrIOPoll(Capability *cap) +void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { - CapIOManager *iomgr = cap->iomgr; - /* Loop until we've woken up some threads. This loop is needed because the * poll() timing isn't accurate, we sometimes sleep for a while but not * long enough to wake up a thread in a threadDelay. Or we may need to @@ -409,14 +402,14 @@ void awaitCompletedTimeoutsOrIOPoll(Capability *cap) !isEmptyClosureTable(&iomgr->aiop_table)); Time now = getProcessElapsedTime(); - processTimeoutCompletions(cap, now); + processTimeoutCompletions(iomgr, now); /* If we didn't wake any threads due to expiring timeouts, then we need * to wait on I/O. Or to put it another way, even if we did wake some * threads, we'll still poll (but not wait) for I/O. This is to ensure * we avoid starving threads blocked on I/O. */ - bool wait = emptyRunQueue(cap); + bool wait = emptyRunQueue(iomgr->cap); /* Decide if we are going to wait if no I/O is ready, either: * poll only, wait indefinitely, or wait until a timeout. @@ -461,7 +454,7 @@ void awaitCompletedTimeoutsOrIOPoll(Capability *cap) } else if (res > 0) { int ncompletions = res; ASSERT(ncompletions <= (int)nfds); - processIOCompletions(cap, iomgr, ncompletions); + processIOCompletions(iomgr, ncompletions); } else if (errno == EINTR) { /* We got interrupted by a signal. In the non-threaded RTS, if the @@ -471,7 +464,7 @@ void awaitCompletedTimeoutsOrIOPoll(Capability *cap) * signal is serviced. */ #if defined(RTS_USER_SIGNALS) - if (startPendingSignalHandlers(cap)) break; + if (startPendingSignalHandlers(iomgr->cap)) break; #endif /* We can also be interrupted by the shutdown signal handler, which @@ -485,7 +478,7 @@ void awaitCompletedTimeoutsOrIOPoll(Capability *cap) reportPollError(res, nfds); } - } while (emptyRunQueue(cap) + } while (emptyRunQueue(iomgr->cap) && (getSchedState() == SCHED_RUNNING)); } @@ -507,12 +500,12 @@ static void reportPollError(int res, nfds_t nfds) /* Helper function to double the size of the aiop_table and aiop_poll_table. */ -static bool enlargeTables(Capability *cap, CapIOManager *iomgr) +static bool enlargeTables(CapIOManager *iomgr) { int oldcapacity = capacityClosureTable(&iomgr->aiop_table); int newcapacity = (oldcapacity == 0) ? 1 : (oldcapacity * 2); - bool ok = enlargeClosureTable(cap, &iomgr->aiop_table, newcapacity); + bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity); if (RTS_UNLIKELY(!ok)) return false; /* Update the auxiliary aiop_poll_table to match */ ===================================== rts/posix/Poll.h ===================================== @@ -19,19 +19,19 @@ void initCapabilityIOManagerPoll(CapIOManager *iomgr); /* Synchronous I/O and timer operations */ -bool syncIOWaitReadyPoll(Capability *cap, StgTSO *tso, +bool syncIOWaitReadyPoll(CapIOManager *iomgr, StgTSO *tso, IOReadOrWrite rw, HsInt fd); -void syncIOCancelPoll(Capability *cap, StgTSO *tso); +void syncIOCancelPoll(CapIOManager *iomgr, StgTSO *tso); /* Asynchronous operations */ -bool asyncIOWaitReadyPoll(Capability *cap, StgAsyncIOOp *aiop, +bool asyncIOWaitReadyPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop, IOReadOrWrite rw, int fd); -void asyncIOCancelPoll(Capability *cap, StgAsyncIOOp *aiop); +void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop); /* Scheduler operations */ bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr); -void pollCompletedTimeoutsOrIOPoll(Capability *cap); -void awaitCompletedTimeoutsOrIOPoll(Capability *cap); +void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); +void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); #endif /* IOMGR_ENABLED_POLL */ ===================================== rts/posix/Select.c ===================================== @@ -93,9 +93,8 @@ LowResTime getDelayTarget (HsInt us) * if this is true, then our time has expired. * (idea due to Andy Gill). */ -static bool wakeUpSleepingThreads (Capability *cap, LowResTime now) +static bool wakeUpSleepingThreads (CapIOManager *iomgr, LowResTime now) { - CapIOManager *iomgr = cap->iomgr; StgTSO *tso; bool flag = false; @@ -109,7 +108,7 @@ static bool wakeUpSleepingThreads (Capability *cap, LowResTime now) tso->_link = END_TSO_QUEUE; IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %" FMT_StgThreadID "\n", tso->id)); - pushOnRunQueue(cap,tso); + pushOnRunQueue(iomgr->cap,tso); flag = true; } return flag; @@ -217,9 +216,8 @@ static enum FdState fdPollWriteState (int fd) * */ void -awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) +awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) { - CapIOManager *iomgr = cap->iomgr; StgTSO *tso, *prev, *next; fd_set rfd,wfd; int numFound; @@ -244,7 +242,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) do { now = getLowResTimeOfDay(); - if (wakeUpSleepingThreads(cap, now)) { + if (wakeUpSleepingThreads(iomgr, now)) { return; } @@ -355,7 +353,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) */ #if defined(RTS_USER_SIGNALS) if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) { - startSignalHandlers(cap); + startSignalHandlers(iomgr->cap); return; /* still hold the lock */ } #endif @@ -368,12 +366,12 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) /* check for threads that need waking up */ - wakeUpSleepingThreads(cap, getLowResTimeOfDay()); + wakeUpSleepingThreads(iomgr, getLowResTimeOfDay()); /* If new runnable threads have arrived, stop waiting for * I/O and run them. */ - if (!emptyRunQueue(cap)) { + if (!emptyRunQueue(iomgr->cap)) { return; /* still hold the lock */ } } @@ -429,7 +427,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) IF_DEBUG(scheduler, debugBelch("Killing blocked thread %" FMT_StgThreadID " on bad fd=%i\n", tso->id, fd)); - raiseAsync(cap, tso, + raiseAsync(iomgr->cap, tso, (StgClosure *)blockedOnBadFD_closure, false, NULL); break; case RTS_FD_IS_READY: @@ -438,13 +436,13 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) tso->id)); tso->why_blocked = NotBlocked; tso->_link = END_TSO_QUEUE; - pushOnRunQueue(cap,tso); + pushOnRunQueue(iomgr->cap,tso); break; case RTS_FD_IS_BLOCKING: if (prev == NULL) iomgr->blocked_queue_hd = tso; else - setTSOLink(cap, prev, tso); + setTSOLink(iomgr->cap, prev, tso); prev = tso; break; } @@ -460,7 +458,7 @@ awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait) } } while (wait && getSchedState() == SCHED_RUNNING - && emptyRunQueue(cap)); + && emptyRunQueue(iomgr->cap)); } #endif /* IOMGR_ENABLED_SELECT */ ===================================== rts/posix/Select.h ===================================== @@ -15,7 +15,7 @@ typedef StgWord LowResTime; LowResTime getDelayTarget (HsInt us); -void awaitCompletedTimeoutsOrIOSelect(Capability *cap, bool wait); +void awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait); #include "EndPrivate.h" ===================================== rts/posix/Signals.c ===================================== @@ -9,21 +9,12 @@ #include "rts/PosixSource.h" #include "Rts.h" -#include "Schedule.h" #include "RtsSignals.h" -#include "Signals.h" -#include "IOManager.h" #include "RtsUtils.h" +#include "Schedule.h" #include "Prelude.h" -#include "Ticker.h" #include "ThreadLabels.h" -#include "Libdw.h" - -/* TODO: eliminate this include. This file should be about signals, not be - * part of an I/O manager implementation. The code here that are really part - * of an I/O manager should be moved into an appropriate I/O manager impl. - */ -#include "IOManagerInternals.h" +#include "MIO.h" #if defined(alpha_HOST_ARCH) # if defined(linux_HOST_OS) @@ -45,10 +36,6 @@ # include <errno.h> #endif -#if defined(HAVE_EVENTFD_H) -# include <sys/eventfd.h> -#endif - #if defined(HAVE_TERMIOS_H) #include <termios.h> #endif @@ -134,110 +121,6 @@ more_handlers(int sig) nHandlers = sig + 1; } -// Here's the pipe into which we will send our signals -static int io_manager_wakeup_fd = -1; -static int timer_manager_control_wr_fd = -1; - -#define IO_MANAGER_WAKEUP 0xff -#define IO_MANAGER_DIE 0xfe -#define IO_MANAGER_SYNC 0xfd - -void setTimerManagerControlFd(int fd) { - RELAXED_STORE(&timer_manager_control_wr_fd, fd); -} - -void -setIOManagerWakeupFd (int fd) -{ - // only called when THREADED_RTS, but unconditionally - // compiled here because GHC.Event.Control depends on it. - SEQ_CST_STORE(&io_manager_wakeup_fd, fd); -} - -/* ----------------------------------------------------------------------------- - * Wake up at least one IO or timer manager HS thread. - * -------------------------------------------------------------------------- */ -void -ioManagerWakeup (void) -{ - int r; - const int wakeup_fd = SEQ_CST_LOAD(&io_manager_wakeup_fd); - // Wake up the IO Manager thread by sending a byte down its pipe - if (wakeup_fd >= 0) { -#if defined(HAVE_EVENTFD) - StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP; - r = write(wakeup_fd, (char *) &n, 8); -#else - StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP; - r = write(wakeup_fd, &byte, 1); -#endif - /* N.B. If the TimerManager is shutting down as we run this - * then there is a possibility that our first read of - * io_manager_wakeup_fd is non-negative, but before we get to the - * write the file is closed. If this occurs, io_manager_wakeup_fd - * will be written into with -1 (GHC.Event.Control does this prior - * to closing), so checking this allows us to distinguish this case. - * To ensure we observe the correct ordering, we declare the - * io_manager_wakeup_fd as volatile. - * Since this is not an error condition, we do not print the error - * message in this case. - */ - if (r == -1 && SEQ_CST_LOAD(&io_manager_wakeup_fd) >= 0) { - sysErrorBelch("ioManagerWakeup: write"); - } - } -} - -#if defined(THREADED_RTS) -void -ioManagerDie (void) -{ - StgWord8 byte = (StgWord8)IO_MANAGER_DIE; - uint32_t i; - int r; - - { - // Shut down timer manager - const int fd = RELAXED_LOAD(&timer_manager_control_wr_fd); - if (0 <= fd) { - r = write(fd, &byte, 1); - if (r == -1) { sysErrorBelch("ioManagerDie: write"); } - RELAXED_STORE(&timer_manager_control_wr_fd, -1); - } - } - - { - // Shut down IO managers - for (i=0; i < getNumCapabilities(); i++) { - const int fd = RELAXED_LOAD(&getCapability(i)->iomgr->control_fd); - if (0 <= fd) { - r = write(fd, &byte, 1); - if (r == -1) { sysErrorBelch("ioManagerDie: write"); } - RELAXED_STORE(&getCapability(i)->iomgr->control_fd, -1); - } - } - } -} - -void -ioManagerStartCap (Capability **cap) -{ - rts_evalIO(cap,ensureIOManagerIsRunning_closure,NULL); -} - -void -ioManagerStart (void) -{ - // Make sure the IO manager thread is running - Capability *cap; - if (SEQ_CST_LOAD(&timer_manager_control_wr_fd) < 0 || SEQ_CST_LOAD(&io_manager_wakeup_fd) < 0) { - cap = rts_lock(); - ioManagerStartCap(&cap); - rts_unlock(cap); - } -} -#endif - #if !defined(THREADED_RTS) #define N_PENDING_HANDLERS 16 @@ -260,31 +143,9 @@ generic_handler(int sig USED_IF_THREADS, void *p STG_UNUSED) { #if defined(THREADED_RTS) - - StgWord8 buf[sizeof(siginfo_t) + 1]; - int r; - - buf[0] = sig; - if (info == NULL) { - // info may be NULL on Solaris (see #3790) - memset(buf+1, 0, sizeof(siginfo_t)); - } else { - memcpy(buf+1, info, sizeof(siginfo_t)); - } - - int timer_control_fd = RELAXED_LOAD(&timer_manager_control_wr_fd); - if (0 <= timer_control_fd) - { - r = write(timer_control_fd, buf, sizeof(siginfo_t)+1); - if (r == -1 && errno == EAGAIN) { - errorBelch("lost signal due to full pipe: %d\n", sig); - } - } - - // If the IO manager hasn't told us what the FD of the write end - // of its pipe is, there's not much we can do here, so just ignore - // the signal.. - + //TODO: This calls MIO directly. We should go via IOManager API. + // The IOManager API should be extended to cover signals. + timerManagerNotifySignal(sig, info); #else /* not THREADED_RTS */ /* Can't call allocate from here. Probably can't call malloc ===================================== rts/posix/Signals.h ===================================== @@ -27,18 +27,6 @@ void startSignalHandlers(Capability *cap); void install_vtalrm_handler(int sig, TickProc handle_tick); -/* Communicating with the IO manager thread (see GHC.Conc). - * - * TODO: these I/O manager things are not related to signals and ought to live - * elsewhere, e.g. in a module specifically for the I/O manager. - */ -void ioManagerWakeup (void); -#if defined(THREADED_RTS) -void ioManagerDie (void); -void ioManagerStart (void); -void ioManagerStartCap (/* inout */ Capability **cap); -#endif - extern StgInt *signal_handlers; #include "EndPrivate.h" ===================================== rts/posix/Timeout.c ===================================== @@ -26,7 +26,7 @@ */ #if defined(IOMGR_ENABLED_POLL) -bool syncDelayTimeout(Capability *cap, StgTSO *tso, HsInt us_delay) +bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay) { Time now = getProcessElapsedTime(); Time target; @@ -42,16 +42,16 @@ bool syncDelayTimeout(Capability *cap, StgTSO *tso, HsInt us_delay) /* fill in a new timeout queue entry */ StgTimeout *timeout; - timeout = (StgTimeout *)allocateMightFail(cap, sizeofW(StgTimeout)); + timeout = (StgTimeout *)allocateMightFail(iomgr->cap, sizeofW(StgTimeout)); if (RTS_UNLIKELY(timeout == NULL)) { return false; } union NotifyCompletion notify = { .tso = tso }; - initElemTimeoutQueue(timeout, notify, NotifyTSO, cap->r.rCCCS); + initElemTimeoutQueue(timeout, notify, NotifyTSO, iomgr->cap->r.rCCCS); ASSERT(tso->why_blocked == NotBlocked); tso->why_blocked = BlockedOnDelay; tso->block_info.timeout = timeout; - insertTimeoutQueue(&cap->iomgr->timeout_queue, timeout, target); + insertTimeoutQueue(&iomgr->timeout_queue, timeout, target); debugTrace(DEBUG_iomanager, "timer for delay of %lld usec installed at time %lld ns", @@ -60,18 +60,18 @@ bool syncDelayTimeout(Capability *cap, StgTSO *tso, HsInt us_delay) } -void syncDelayCancelTimeout(Capability *cap, StgTSO *tso) +void syncDelayCancelTimeout(CapIOManager *iomgr, StgTSO *tso) { ASSERT(tso->why_blocked == BlockedOnDelay); StgTimeoutQueue *timeout = tso->block_info.timeout; - deleteTimeoutQueue(&cap->iomgr->timeout_queue, timeout); + deleteTimeoutQueue(&iomgr->timeout_queue, timeout); tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; /* the timeout is no longer accessible from anywhere (except here) */ IF_NONMOVING_WRITE_BARRIER_ENABLED { - updateRemembSetPushClosure(cap, (StgClosure *)timeout); + updateRemembSetPushClosure(iomgr->cap, (StgClosure *)timeout); } /* We don't put the TSO back on the run queue or change the why_blocked @@ -79,7 +79,7 @@ void syncDelayCancelTimeout(Capability *cap, StgTSO *tso) */ } -static void notifyTimeoutCompletion(Capability *cap, StgTimeout *timeout); +static void notifyTimeoutCompletion(CapIOManager *iomgr, StgTimeout *timeout); /* We use the 64bit Time type from rts/Time.h so our max time (in nanosecond * precision) is over 290 years from the epoch of the monotonic clock. @@ -90,10 +90,8 @@ static void notifyTimeoutCompletion(Capability *cap, StgTimeout *timeout); * With 64bit Time we do not need to worry about clock wraparound and can just * use the simple formula. */ -void processTimeoutCompletions(Capability *cap, Time now) +void processTimeoutCompletions(CapIOManager *iomgr, Time now) { - CapIOManager *iomgr = cap->iomgr; - /* Pop entries from the front of the sleeping queue that are past their * wake time, and unblock the corresponding MVars. */ @@ -105,17 +103,17 @@ void processTimeoutCompletions(Capability *cap, Time now) debugTrace(DEBUG_iomanager,"timer expired at %lld ns", waketime); StgTimeout *timeout; deleteMinTimeoutQueue(&iomgr->timeout_queue, &timeout); - notifyTimeoutCompletion(cap, timeout); + notifyTimeoutCompletion(iomgr, timeout); /* the timeout is no longer accessible from anywhere (except here) */ IF_NONMOVING_WRITE_BARRIER_ENABLED { - updateRemembSetPushClosure(cap, (StgClosure *)timeout); + updateRemembSetPushClosure(iomgr->cap, (StgClosure *)timeout); } } } -static void notifyTimeoutCompletion(Capability *cap, StgTimeout *timeout) +static void notifyTimeoutCompletion(CapIOManager *iomgr, StgTimeout *timeout) { switch (timeout->notify_type) { case NotifyTSO: @@ -123,11 +121,11 @@ static void notifyTimeoutCompletion(Capability *cap, StgTimeout *timeout) StgTSO *tso = timeout->notify.tso; tso->why_blocked = NotBlocked; tso->_link = END_TSO_QUEUE; - pushOnRunQueue(cap, tso); + pushOnRunQueue(iomgr->cap, tso); break; } case NotifyMVar: - performTryPutMVar(cap, timeout->notify.mvar, Unit_closure); + performTryPutMVar(iomgr->cap, timeout->notify.mvar, Unit_closure); break; case NotifyTVar: ===================================== rts/posix/Timeout.h ===================================== @@ -12,9 +12,9 @@ #include "BeginPrivate.h" -bool syncDelayTimeout(Capability *cap, StgTSO *tso, HsInt us_delay); +bool syncDelayTimeout(CapIOManager *iomgr, StgTSO *tso, HsInt us_delay); -void syncDelayCancelTimeout(Capability *cap, StgTSO *tso); +void syncDelayCancelTimeout(CapIOManager *iomgr, StgTSO *tso); /* Process the completion of any timeouts that have expired: this means * notifying whatever is waiting on the timeout, a thread, an MVar or TVar. @@ -24,7 +24,7 @@ void syncDelayCancelTimeout(Capability *cap, StgTSO *tso); * No result is returned: callers can check if there are now any runnable * threads by consulting the scheduler's run queue. */ -void processTimeoutCompletions(Capability *cap, Time now); +void processTimeoutCompletions(CapIOManager *iomgr, Time now); /* Utility to compute the timeout wait time (in milliseconds) between now and * the next timer expiry (if any), or no waiting (if !wait). ===================================== rts/rts.cabal ===================================== @@ -581,6 +581,7 @@ library posix/Ticker.c posix/OSMem.c posix/OSThreads.c + posix/MIO.c posix/Poll.c posix/Select.c posix/Signals.c View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/694defb0348b886d4733d663a6f96b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/694defb0348b886d4733d663a6f96b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/tyop] Infix holes in types (#11107)
by Vladislav Zavialov (＠int-index) 03 Mar '26

03 Mar '26

Vladislav Zavialov pushed to branch wip/int-index/tyop at Glasgow Haskell Compiler / GHC Commits: ae3491b0 by Vladislav Zavialov at 2026-03-03T02:12:25+03:00 Infix holes in types (#11107) This patch introduces several improvements that follow naturally from refactoring HsOpTy to represent the operator as an HsType, aligning it with the approach taken by OpApp and HsExpr. User-facing changes: 1. Infix holes (t1 `_` t2) are now permitted in types, following the precedent set by term-level expressions. Test case: T11107 2. Error messages for illegal promotion ticks are now reported at more precise source locations. Test case: T17865 Internal changes: * The definition of HsOpTy now mirrors that of OpApp: | HsOpTy (XOpTy p) (LHsType p) (LHsType p) (LHsType p) | OpApp (XOpApp p) (LHsExpr p) (LHsExpr p) (LHsExpr p) This moves us one step closer to unifying HsType and HsExpr. * Ignoring locations, the old pattern match (HsOpTy x prom lhs op rhs) is now written as (HsOpTy x lhs (HsTyVar x' prom op) rhs) but we also handle (HsOpTy x lhs (HsWildCardTy x') rhs) Constructors other than HsTyVar and HsWildCardTy never appear in the operator position. * The various definitions across the compiler have been updated to work with the new representation, drawing inspiration from the term-level pipeline where appropriate. For example, ppr_infix_ty <=> ppr_infix_expr get_tyop <=> get_op lookupTypeFixityRn <=> lookupExprFixityRn (the latter is factored out from rnExpr) Test cases: T11107 T17865 - - - - - 30 changed files: - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Fixity.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Pat.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/ThToHs.hs - compiler/Language/Haskell/Syntax/Type.hs - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_fail/T17865.stderr - + testsuite/tests/partial-sigs/should_compile/T11107.hs - + testsuite/tests/partial-sigs/should_compile/T11107.stderr - testsuite/tests/partial-sigs/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Convert.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs Changes: ===================================== compiler/GHC/Hs/Type.hs ===================================== @@ -684,11 +684,12 @@ ignoreParens ty = ty mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs mkAnonWildCardTy tok = HsWildCardTy tok -mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) +mkHsOpTy :: (Anno (IdOccGhcP p) ~ EpAnn a) => PromotionFlag - -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p)) + -> LHsType (GhcPass p) -> LIdOccP (GhcPass p) -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2 +mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField ty1 tyop ty2 + where tyop = L (l2l op) $ HsTyVar noAnn prom op mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2) @@ -746,7 +747,7 @@ hsTyGetAppHead_maybe = go go (L _ (HsTyVar _ _ ln)) = Just ln go (L _ (HsAppTy _ l _)) = go l go (L _ (HsAppKindTy _ t _)) = go t - go (L _ (HsOpTy _ _ _ ln _)) = Just ln + go (L _ (HsOpTy _ _ op _)) = go op go (L _ (HsParTy _ t)) = go t go (L _ (HsKindSig _ t _)) = go t go _ = Nothing @@ -1458,9 +1459,14 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k -ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) - = sep [ ppr_mono_lty ty1 - , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ] +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) + | Just pp_op <- ppr_infix_ty tyop + = sep [pp_ty1, sep [pp_op, pp_ty2]] + | otherwise + = hang (ppr tyop) 2 (sep [pp_ty1, pp_ty2]) + where + pp_ty1 = ppr_mono_lty ty1 + pp_ty2 = ppr_mono_lty ty2 ppr_mono_ty (HsParTy _ ty) = parens (ppr_mono_lty ty) -- Put the parens in where the user did @@ -1477,6 +1483,11 @@ ppr_mono_ty (XHsType t) = case ghcPass @p of HsRecTy _ flds -> pprHsConDeclRecFields flds GhcRn -> ppr t +ppr_infix_ty :: (OutputableBndrId p) => LHsType (GhcPass p) -> Maybe SDoc +ppr_infix_ty (L _ (HsTyVar _ prom (L _ op))) = Just (pprOccWithTick Infix prom op) +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`") +ppr_infix_ty _ = Nothing + -------------------------- ppr_fun_ty :: (OutputableBndrId p) => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -632,7 +632,7 @@ nlHsTyConApp :: forall p a. IsSrcSpanAnn p a nlHsTyConApp prom fixity tycon tys | Infix <- fixity , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys - = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest + = foldl' mk_app (noLocA $ mkHsOpTy prom ty1 (noLocA tycon) ty2) rest | otherwise = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys where ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -1473,8 +1473,7 @@ repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys repTy (HsSumTy _ tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) +repTy (HsOpTy _ ty1 op ty2) = repLTy ((op `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy _ t) = repLTy t repTy (HsStarTy _ _) = repTStar repTy (HsKindSig _ t k) = do ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1921,9 +1921,9 @@ instance ToHie (LocatedA (HsType GhcRn)) where HsSumTy _ tys -> [ toHie tys ] - HsOpTy _ _prom a op b -> + HsOpTy _ a op b -> [ toHie a - , toHie $ C Use op + , toHie op , toHie b ] HsParTy _ a -> ===================================== compiler/GHC/Parser.y ===================================== @@ -2316,15 +2316,14 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) } : ftype %shift { $1 } | ftype tyop infixtype { $1 >>= \ $1 -> $3 >>= \ $3 -> - do { let (op, prom) = $2 - ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op) - ; mkHsOpTyPV prom $1 op $3 } } + do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2) + ; mkHsOpTyPV $1 $2 $3 } } | unpackedness infixtype { $2 >>= \ $2 -> mkUnpackednessPV $1 $2 } ftype :: { forall b. DisambTD b => PV (LocatedA b) } : atype { mkHsAppTyHeadPV $1 } - | tyop { failOpFewArgs (fst $1) } + | tyop { failOpFewArgs $1 } | ftype tyarg { $1 >>= \ $1 -> mkHsAppTyPV $1 $2 } | ftype PREFIX_AT atype { $1 >>= \ $1 -> @@ -2334,15 +2333,12 @@ tyarg :: { LHsType GhcPs } : atype { $1 } | unpackedness atype {% addUnpackednessP $1 $2 } -tyop :: { (LocatedN RdrName, PromotionFlag) } - : qtyconop { ($1, NotPromoted) } - | tyvarop { ($1, NotPromoted) } - | SIMPLEQUOTE qconop {% do { op <- amsr (sLL $1 $> (unLoc $2)) - (NameAnnQuote (epTok $1) (gl $2) []) - ; return (op, IsPromoted) } } - | SIMPLEQUOTE varop {% do { op <- amsr (sLL $1 $> (unLoc $2)) - (NameAnnQuote (epTok $1) (gl $2) []) - ; return (op, IsPromoted) } } +tyop :: { LHsType GhcPs } + : qtyconop { sL1a $1 (HsTyVar noAnn NotPromoted $1) } + | tyvarop { sL1a $1 (HsTyVar noAnn NotPromoted $1) } + | SIMPLEQUOTE qconop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) } + | SIMPLEQUOTE varop { sLLa $1 $> (HsTyVar (epTok $1) IsPromoted $2) } + | '`' '_' '`' { sLLa $1 $> (mkAnonWildCardTy (epTok $2)) } -- TODO (int-index): NameBackquotes; reuse hole_op atype :: { LHsType GhcPs } : ntgtycon {% amsA' (sL1 $1 (HsTyVar noAnn NotPromoted $1)) } -- Not including unit tuples @@ -4464,12 +4460,12 @@ hintLinear span = do unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction -- Does this look like (a %m)? -looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool -looksLikeMult ty1 l_op ty2 - | Unqual op_name <- unLoc l_op +looksLikeMult :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> Bool +looksLikeMult ty1 tyop ty2 + | HsTyVar _ _ (L _ (Unqual op_name)) <- unLoc tyop , occNameFS op_name == fsLit "%" , Strict.Just ty1_pos <- getBufSpan (getLocA ty1) - , Strict.Just pct_pos <- getBufSpan (getLocA l_op) + , Strict.Just pct_pos <- getBufSpan (getLocA tyop) , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) , bufSpanEnd ty1_pos /= bufSpanStart pct_pos , bufSpanEnd pct_pos == bufSpanStart ty2_pos ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -1137,8 +1137,8 @@ checkTyClHdr is_cls ty go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix | isRdrTc tc = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l) - go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix - | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l) + go cs l (HsOpTy _ t1 tyop t2) acc ops cps _fix + = goL (cs Semi.<> comments l) tyop (lhs:rhs:acc) ops cps Infix where lhs = HsValArg noExtField t1 rhs = HsValArg noExtField t2 go cs l (HsParTy (o,c) ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix @@ -2401,7 +2401,7 @@ class DisambTD b where -- | Disambiguate @f \@t@ (visible kind application) mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @f \# x@ (infix operator) - mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) + mkHsOpTyPV :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) @@ -2409,8 +2409,8 @@ instance DisambTD (HsType GhcPs) where mkHsAppTyHeadPV = return mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) - mkHsOpTyPV prom t1 op t2 = do - let (L l ty) = mkLHsOpTy prom t1 op t2 + mkHsOpTyPV t1 tyop t2 = do + let (L l ty) = mkLHsOpTy t1 tyop t2 !cs <- getCommentsFor (locA l) return (L (addCommentsToEpAnn l cs) ty) mkUnpackednessPV = addUnpackednessP @@ -2452,11 +2452,11 @@ instance DisambTD DataConBuilder where addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $ (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) - mkHsOpTyPV prom lhs tc rhs = do + mkHsOpTyPV lhs op@(L _ (HsTyVar _ prom tc)) rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative data_con <- eitherToP $ tyConToDataCon tc !cs <- getCommentsFor (locA l) - checkNotPromotedDataCon prom data_con + checkNotPromotedDataCon (getLocA op) prom data_con return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs) where l = combineLocsA lhs rhs @@ -2465,6 +2465,9 @@ instance DisambTD DataConBuilder where addError $ mkPlainErrorMsgEnvelope (locA l) $ (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) check_no_ops _ = return () + mkHsOpTyPV _ (L l (HsWildCardTy _)) _ = + addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole + mkHsOpTyPV _ op _ = pprPanic "mkHsOpTyPV: impossible type operator" (ppr op) mkUnpackednessPV unpk constr_stuff | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff @@ -2480,7 +2483,7 @@ instance DisambTD DataConBuilder where tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) tyToDataConBuilder (L l (HsTyVar _ prom v)) = do data_con <- eitherToP $ tyConToDataCon v - checkNotPromotedDataCon prom data_con + checkNotPromotedDataCon (locA l) prom data_con return $ L l (PrefixDataConBuilder nilOL data_con) tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) @@ -2493,10 +2496,10 @@ tyToDataConBuilder t = (PsErrInvalidDataCon (unLoc t)) -- | Rejects declarations such as @data T = 'MkT@ (note the leading tick). -checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV () -checkNotPromotedDataCon NotPromoted _ = return () -checkNotPromotedDataCon IsPromoted (L l name) = - addError $ mkPlainErrorMsgEnvelope (locA l) $ +checkNotPromotedDataCon :: SrcSpan -> PromotionFlag -> LocatedN RdrName -> PV () +checkNotPromotedDataCon _ NotPromoted _ = return () +checkNotPromotedDataCon loc IsPromoted (L _ name) = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalPromotionQuoteDataCon name mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs) @@ -3452,12 +3455,15 @@ failSpliceOrQuoteTwice lvl = warnStarIsType :: SrcSpan -> P () warnStarIsType span = addPsMessage span PsWarnStarIsType -failOpFewArgs :: MonadP m => LocatedN RdrName -> m a -failOpFewArgs (L loc op) = +failOpFewArgs :: MonadP m => LHsType GhcPs -> m a +failOpFewArgs (L _ (HsTyVar _ _ (L loc op))) = do { star_is_type <- getBit StarIsTypeBit ; let is_star_type = if star_is_type then StarIsType else StarIsNotType ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrOpFewArgs is_star_type op) } +failOpFewArgs (L l (HsWildCardTy _)) = + addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole +failOpFewArgs op = pprPanic "failOpFewArgs: impossible type operator" (ppr op) requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m () requireExplicitNamespaces kw = do @@ -3693,10 +3699,10 @@ mkSumOrTuplePat l Boxed a@Sum{} _ = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a -mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs -mkLHsOpTy prom x op y = +mkLHsOpTy :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy x op y = let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y - in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y) + in L (noAnnSrcSpan loc) (HsOpTy noExtField x op y) mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -50,7 +50,6 @@ import GHC.Unit.Module ( isInteractiveModule ) import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel -import GHC.Types.Fixity import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set @@ -401,12 +400,7 @@ rnExpr (OpApp _ e1 op e2) -- we used to avoid fixity stuff, but we can't easily tell any -- more, so I've removed the test. Adding HsPars in GHC.Tc.Deriv.Generate -- should prevent bad things happening. - ; fixity <- case op' of - L _ (HsVar _ (L _ (WithUserRdr _ n))) -> lookupFixityRn n - L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f - _ -> return (Fixity minPrecedence InfixL) - -- c.f. lookupFixity for unbound - + ; fixity <- lookupExprFixityRn op' ; lexical_negation <- xoptM LangExt.LexicalNegation ; let negation_handling | lexical_negation = KeepNegationIntact | otherwise = ReassociateNegation ===================================== compiler/GHC/Rename/Fixity.hs ===================================== @@ -11,7 +11,8 @@ module GHC.Rename.Fixity , lookupFixityRn , lookupFixityRn_help , lookupFieldFixityRn - , lookupTyFixityRn + , lookupExprFixityRn + , lookupTypeFixityRn ) where import GHC.Prelude @@ -26,6 +27,7 @@ import GHC.Unit.Module.ModIface import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Types.Name.Reader import GHC.Types.Fixity import GHC.Types.SrcLoc @@ -198,8 +200,19 @@ lookupFixityRn_help name doc = text "Checking fixity for" <+> ppr name --------------- -lookupTyFixityRn :: LocatedN Name -> RnM Fixity -lookupTyFixityRn = lookupFixityRn . unLoc - lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n) + +lookupExprFixityRn :: LHsExpr GhcRn -> RnM Fixity +lookupExprFixityRn e = + case e of + L _ (HsVar _ op) -> lookupFixityRn (unLocWithUserRdr op) + L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f + _ -> return (Fixity minPrecedence InfixL) + -- c.f. lookupFixity for unbound + +lookupTypeFixityRn :: LHsType GhcRn -> RnM Fixity +lookupTypeFixityRn t = + case t of + L _ (HsTyVar _ _ op) -> lookupFixityRn (unLocWithUserRdr op) + _ -> return (Fixity minPrecedence InfixL) ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -54,7 +54,7 @@ import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNames , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn - , lookupTyFixityRn ) + , lookupTypeFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr ( pprHsDocContext ) @@ -67,7 +67,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel -import GHC.Types.Error import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity ) @@ -551,16 +550,13 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) ; checkPromotedDataConName env tv Prefix ip name ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFV name) } -rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) - = setSrcSpan (getLocA l_op) $ - do { let op_rdr = unLoc l_op - ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op - ; let op_name = unLoc l_op' - ; fix <- lookupTyFixityRn l_op' +rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2) + = setSrcSpan (getLocA tyop) $ + do { (tyop', fvs1) <- rnHsTyOp env ty tyop + ; fix <- lookupTypeFixityRn tyop' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' - ; checkPromotedDataConName env ty Infix prom op_name + ; res_ty <- mkHsOpTyRn tyop' fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty) @@ -770,15 +766,20 @@ rnLTyVar (L loc rdr_name) ; return (L loc tyvar) } -------------- -rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName - -> RnM (LocatedN Name, FreeVars) -rnHsTyOp env overall_ty (L loc op) +rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs + -> RnM (LHsType GhcRn, FreeVars) +rnHsTyOp env overall_ty tyop + | L l (HsTyVar ann prom (L loc op)) <- tyop = do { op' <- rnTyVar env op ; unlessXOptM LangExt.TypeOperators $ if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env then addDiagnostic TcRnTypeEqualityRequiresOperators - else addErr $ TcRnIllegalTypeOperator overall_ty op - ; return (L loc op', unitFV op') } + else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op + ; checkPromotedDataConName env overall_ty Infix prom op' + ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op'))) + ; return (tyop', unitFV op') } + | otherwise + = rnLHsTyKi env tyop -------------- checkWildCard :: RnTyKiEnv @@ -1400,33 +1401,33 @@ precedence and does not require rearrangement. --------------- -- Building (ty1 `op1` (ty2a `op2` ty2b)) -mkHsOpTyRn :: PromotionFlag - -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn +mkHsOpTyRn :: LHsType GhcRn + -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b)) - = do { fix2 <- lookupTyFixityRn (fmap getName op2) - ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } +mkHsOpTyRn tyop1 fix1 ty1 (L loc2 (HsOpTy _ ty2a tyop2 ty2b)) + = do { fix2 <- lookupTypeFixityRn tyop2 + ; mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangement - = return (HsOpTy noExtField prom1 ty1 op1 ty2) +mkHsOpTyRn tyop _ ty1 ty2 -- Default case, no rearrangement + = return (HsOpTy noExtField ty1 tyop ty2) --------------- -mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn - -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn +mk_hs_op_ty :: LHsType GhcRn -> Fixity -> LHsType GhcRn + -> LHsType GhcRn -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpanAnnA -> RnM (HsType GhcRn) -mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 - | nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1) - (NormalOp (unLoc op2),fix2) +mk_hs_op_ty tyop1 fix1 ty1 tyop2 fix2 ty2a ty2b loc2 + | nofix_error = do { precParseErr (get_tyop tyop1,fix1) + (get_tyop tyop2,fix2) ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) } | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b) - new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a + new_ty <- mkHsOpTyRn tyop1 fix1 ty1 ty2a ; return (noLocA new_ty `op2ty` ty2b) } where - lhs `op1ty` rhs = HsOpTy noExtField prom1 lhs op1 rhs - lhs `op2ty` rhs = HsOpTy noExtField prom2 lhs op2 rhs + lhs `op1ty` rhs = HsOpTy noExtField lhs tyop1 rhs + lhs `op2ty` rhs = HsOpTy noExtField lhs tyop2 rhs (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1493,6 +1494,11 @@ get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv get_op (L _ (XExpr (HsRecSelRn fld))) = RecFldOp fld get_op other = pprPanic "get_op" (ppr other) +get_tyop :: LHsType GhcRn -> OpName +get_tyop (L _ (HsTyVar _ _ n)) = NormalOp (unLoc n) +get_tyop (L _ (HsWildCardTy _)) = UnboundOp (Unqual (mkVarOcc "_")) +get_tyop other = pprPanic "get_tyop" (ppr other) + -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK @@ -2119,8 +2125,8 @@ extract_lty (L _ ty) acc extract_hs_mult_ann m $ -- See Note [Ordering of implicit variables] extract_lty ty2 acc HsIParamTy _ _ ty -> extract_lty ty acc - HsOpTy _ _ ty1 tv ty2 -> extract_lty ty1 $ - extract_tv tv $ + HsOpTy _ ty1 op ty2 -> extract_lty ty1 $ + extract_lty op $ extract_lty ty2 acc HsParTy _ ty -> extract_lty ty acc HsSpliceTy {} -> acc -- Type splices mention no tvs ===================================== compiler/GHC/Rename/Pat.hs ===================================== @@ -1314,6 +1314,16 @@ rn_ty_pat_var lrdr@(L l rdr) = do name <- lookupTypeOccTPRnM rdr pure (L l $ WithUserRdr rdr name) +rn_tyop_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) +rn_tyop_pat tyop + | L l (HsTyVar ann prom l_op) <- tyop + = do l_op' <- rn_ty_pat_var l_op + let op_name = getName l_op' + when (isDataConName op_name && not (isPromoted prom)) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + return (L l $ HsTyVar ann prom l_op') + | otherwise = rn_lty_pat tyop + -- | Rename type patterns -- -- For the difference between `rn_ty_pat` and `rnHsTyKi` see Note [CpsRn monad] @@ -1373,15 +1383,13 @@ rn_ty_pat (HsSumTy an tys) = do tys' <- mapM rn_lty_pat tys pure (HsSumTy an tys') -rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do +rn_ty_pat (HsOpTy _ ty1 tyop ty2) = do ty1' <- rn_lty_pat ty1 - l_op' <- rn_ty_pat_var l_op + tyop' <- rn_tyop_pat tyop ty2' <- rn_lty_pat ty2 - fix <- liftRn $ lookupTyFixityRn $ fmap getName l_op' - let op_name = getName l_op' - when (isDataConName op_name && not (isPromoted prom)) $ - liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) - liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2' + liftRn $ do + fix <- lookupTypeFixityRn tyop' + mkHsOpTyRn tyop' fix ty1' ty2' rn_ty_pat (HsParTy an ty) = do ty' <- rn_lty_pat ty ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -1136,15 +1136,11 @@ expr_to_type earg = do { lhs' <- go lhs ; rhs' <- unwrap_wc rhs ; return (L l (HsAppKindTy noExtField lhs' rhs')) } - go (L l e@(OpApp _ lhs op rhs)) = + go (L l (OpApp _ lhs op rhs)) = do { lhs' <- go lhs ; op' <- go op ; rhs' <- go rhs - ; op_id <- unwrap_op_tv op' - ; return (L l (HsOpTy noExtField NotPromoted lhs' op_id rhs')) } - where - unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id - unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e) + ; return (L l (HsOpTy noExtField lhs' op' rhs')) } go (L l (HsOverLit _ ol)) = do { let lit = tyLitFromOverloadedLit (ol_val ol) ; return (L l (HsTyLit noExtField lit)) } ===================================== compiler/GHC/Tc/Gen/HsType.hs ===================================== @@ -103,7 +103,7 @@ import GHC.Core.TyCo.Ppr import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name.Env -import GHC.Types.Name.Reader( WithUserRdr(..), lookupLocalRdrOcc ) +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Types.Var.Set import GHC.Core.TyCon @@ -1146,8 +1146,9 @@ tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: inva tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind = tc_fun_type mode mult ty1 ty2 exp_kind -tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind - | op `hasKey` unrestrictedFunTyConKey +tcHsType mode (HsOpTy _ ty1 tyop ty2) exp_kind + | L _ (HsTyVar _ _ op) <- tyop + , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind --------- Foralls @@ -1531,12 +1532,15 @@ splitHsAppTys_maybe hs_ty is_app :: HsType GhcRn -> Bool is_app (HsAppKindTy {}) = True is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _) - = not (op `hasKey` unrestrictedFunTyConKey) + is_app (HsOpTy _ _ tyop _) + | L _ (HsTyVar _ _ op) <- tyop + , unLocWithUserRdr op `hasKey` unrestrictedFunTyConKey -- I'm not sure why this funTyConKey test is necessary -- Can it even happen? Perhaps for t1 `(->)` t2 -- but then maybe it's ok to treat that like a normal -- application rather than using the special rule for HsFunTy + = False + is_app (HsOpTy {}) = True is_app (HsTyVar {}) = True is_app (HsParTy _ (L _ ty)) = is_app ty is_app _ = False @@ -1552,9 +1556,8 @@ splitHsAppTys hs_ty = go (noLocA hs_ty) [] go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as) go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as) go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) - go (L _ (HsOpTy _ prom l op@(L sp _) r)) as - = ( L (l2l sp) (HsTyVar noAnn prom op) - , HsValArg noExtField l : HsValArg noExtField r : as ) + go (L _ (HsOpTy _ l tyop r)) as = + (tyop, HsValArg noExtField l : HsValArg noExtField r : as) go f as = (f, as) --------------------------- ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -549,7 +549,7 @@ pat_to_type (NPat _ (L _ ol) _ _) pat_to_type (ConPat _ lname (InfixCon left right)) = do { lty <- pat_to_type (unLoc left) ; rty <- pat_to_type (unLoc right) - ; let { t = noLocA (HsOpTy noExtField NotPromoted lty lname rty)} + ; let { t = noLocA (mkHsOpTy NotPromoted lty lname rty)} ; pure t } pat_to_type (ConPat _ lname (PrefixCon args)) = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname) } ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -292,7 +292,7 @@ no_anon_wc_ty lty = go lty HsListTy _ ty -> go ty HsTupleTy _ _ tys -> gos tys HsSumTy _ tys -> gos tys - HsOpTy _ _ ty1 _ ty2 -> go ty1 && go ty2 + HsOpTy _ ty1 tyop ty2 -> go tyop && go ty1 && go ty2 HsParTy _ ty -> go ty HsIParamTy _ _ ty -> go ty HsKindSig _ ty kind -> go ty && go kind ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1870,7 +1870,7 @@ cvtTypeKind typeOrKind ty let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y' in do { eq_tc <- returnLA eqTyCon_RDR - ; returnLA (HsOpTy noExtField NotPromoted px eq_tc py) } + ; returnLA (mkHsOpTy NotPromoted px eq_tc py) } -- The long-term goal is to remove the above case entirely and -- subsume it under the case for InfixT. See #15815, comment:6, -- for more details. ===================================== compiler/Language/Haskell/Syntax/Type.hs ===================================== @@ -838,9 +838,9 @@ data HsType pass [LHsType pass] -- Element types (length gives arity) | HsOpTy (XOpTy pass) - PromotionFlag -- Whether explicitly promoted, - -- for the pretty printer - (LHsType pass) (LIdOccP pass) (LHsType pass) + (LHsType pass) + (LHsType pass) + (LHsType pass) | HsParTy (XParTy pass) (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr ===================================== testsuite/tests/parser/should_compile/DumpParsedAst.stderr ===================================== @@ -388,7 +388,6 @@ [])) (HsOpTy (NoExtField) - (NotPromoted) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:11 }) @@ -411,12 +410,22 @@ (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:13 }) - (NameAnnTrailing + (AnnListItem []) (EpaComments [])) - (Exact - {Name: :})) + (HsTyVar + (NoEpTok) + (NotPromoted) + (L + (EpAnn + (EpaSpan { DumpParsedAst.hs:11:13 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (Exact + {Name: :})))) (L (EpAnn (EpaSpan { DumpParsedAst.hs:11:15-16 }) ===================================== testsuite/tests/parser/should_compile/DumpRenamedAst.stderr ===================================== @@ -335,7 +335,6 @@ [])) (HsOpTy (NoExtField) - (NotPromoted) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:11 }) @@ -360,14 +359,24 @@ (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:13 }) - (NameAnnTrailing + (AnnListItem []) (EpaComments [])) - (WithUserRdr - (Exact - {Name: :}) - {Name: :})) + (HsTyVar + (NoEpTok) + (NotPromoted) + (L + (EpAnn + (EpaSpan { DumpRenamedAst.hs:13:13 }) + (NameAnnTrailing + []) + (EpaComments + [])) + (WithUserRdr + (Exact + {Name: :}) + {Name: :})))) (L (EpAnn (EpaSpan { DumpRenamedAst.hs:13:15-16 }) ===================================== testsuite/tests/parser/should_fail/T17865.stderr ===================================== @@ -1,9 +1,8 @@ - -T17865.hs:3:11: error: [GHC-80236] +T17865.hs:3:10: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor MkT -T17865.hs:5:13: error: [GHC-80236] +T17865.hs:5:11: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor MkT' @@ -14,3 +13,4 @@ T17865.hs:7:16: error: [GHC-80236] T17865.hs:9:17: error: [GHC-80236] Illegal promotion quote mark in the declaration of data/newtype constructor (:>$) + ===================================== testsuite/tests/partial-sigs/should_compile/T11107.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module T11107 where + +e :: Int `_` Bool +e = Left 0 \ No newline at end of file ===================================== testsuite/tests/partial-sigs/should_compile/T11107.stderr ===================================== @@ -0,0 +1,4 @@ +T11107.hs:4:10: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Either :: * -> * -> *’ + • In the type signature: e :: Int `_` Bool + ===================================== testsuite/tests/partial-sigs/should_compile/all.T ===================================== @@ -109,3 +109,4 @@ test('T22065', normal, compile, ['']) test('T16152', normal, compile, ['']) test('T20076', expect_broken(20076), compile, ['']) test('T26256', normal, compile, ['']) +test('T11107', normal, compile, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -3965,11 +3965,11 @@ instance ExactPrint (HsType GhcPs) where tys' <- markAnnotated tys an1 <- markClosingParen an0 return (HsSumTy an1 tys') - exact (HsOpTy x promoted t1 lo t2) = do + exact (HsOpTy x t1 lo t2) = do t1' <- markAnnotated t1 lo' <- markAnnotated lo t2' <- markAnnotated t2 - return (HsOpTy x promoted t1' lo' t2') + return (HsOpTy x t1' lo' t2') exact (HsParTy (o,c) ty) = do o' <- markEpToken o ty' <- markAnnotated ty ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs ===================================== @@ -102,7 +102,7 @@ dropHsDocTy = drop_sig_ty drop_ty (HsFunTy x w a b) = HsFunTy x w (drop_lty a) (drop_lty b) drop_ty (HsListTy x a) = HsListTy x (drop_lty a) drop_ty (HsTupleTy x a b) = HsTupleTy x a (map drop_lty b) - drop_ty (HsOpTy x p a b c) = HsOpTy x p (drop_lty a) b (drop_lty c) + drop_ty (HsOpTy x a b c) = HsOpTy x (drop_lty a) (drop_lty b) (drop_lty c) drop_ty (HsParTy x a) = HsParTy x (drop_lty a) drop_ty (HsKindSig x a b) = HsKindSig x (drop_lty a) b drop_ty (HsDocTy _ a _) = drop_ty $ unL a ===================================== utils/haddock/haddock-api/src/Haddock/Backends/LaTeX.hs ===================================== @@ -1345,17 +1345,15 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) unicode = hsep [ppr_mono_lty fun_ty unicode, ppr_mono_lty arg_ty unicode] ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode = hsep [ppr_mono_lty fun_ty unicode, atSign <> ppr_mono_lty arg_ki unicode] -ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode = - ppr_mono_lty ty1 unicode <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode + | Just pp_op <- ppr_infix_ty tyop + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise + = let pp_op = ppr_mono_lty tyop unicode + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - char '\'' <> ppr_op - | otherwise = - ppr_op - ppr_op - | isSymOcc (getOccName op) = ppLDocName op - | otherwise = char '`' <> ppLDocName op <> char '`' + pp_ty1 = ppr_mono_lty ty1 unicode + pp_ty2 = ppr_mono_lty ty2 unicode ppr_mono_ty (HsParTy _ ty) unicode = parens (ppr_mono_lty ty unicode) -- = ppr_mono_lty ty unicode @@ -1367,6 +1365,18 @@ ppr_mono_ty (HsTyLit _ t) u = ppr_tylit t u ppr_mono_ty (HsStarTy _ isUni) unicode = starSymbol (isUni || unicode) ppr_mono_ty (XHsType HsRedacted{}) _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Maybe LaTeX +ppr_infix_ty (L _ (HsTyVar _ prom op)) = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = char '\'' <> pp_op + | otherwise = pp_op + pp_op + | isSymOcc (getOccName op) = ppLDocName op + | otherwise = char '`' <> ppLDocName op <> char '`' +ppr_infix_ty (L _ (HsWildCardTy _)) = Just (text "`_`") +ppr_infix_ty _ = Nothing + ppr_tylit :: HsLit DocNameI -> Bool -> LaTeX ppr_tylit (HsNatural _ n) _ = integer (il_value n) ppr_tylit (HsString _ s) _ = text (show s) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs ===================================== @@ -1863,15 +1863,15 @@ ppr_mono_ty (HsAppKindTy _ fun_ty arg_ki) unicode qual _ = [ ppr_mono_lty fun_ty unicode qual HideEmptyContexts , atSign <> ppr_mono_lty arg_ki unicode qual HideEmptyContexts ] -ppr_mono_ty (HsOpTy _ prom ty1 op ty2) unicode qual _ = - ppr_mono_lty ty1 unicode qual HideEmptyContexts <+> ppr_op_prom <+> ppr_mono_lty ty2 unicode qual HideEmptyContexts +ppr_mono_ty (HsOpTy _ ty1 tyop ty2) unicode qual _ + | Just pp_op <- ppr_infix_ty tyop qual + = pp_ty1 <+> pp_op <+> pp_ty2 + | otherwise + = let pp_op = ppr_mono_lty tyop unicode qual HideEmptyContexts + in hsep [hsep [pp_op, pp_ty1], pp_ty2] where - ppr_op_prom - | isPromoted prom = - promoQuote ppr_op - | otherwise = - ppr_op - ppr_op = ppLDocName qual Infix op + pp_ty1 = ppr_mono_lty ty1 unicode qual HideEmptyContexts + pp_ty2 = ppr_mono_lty ty2 unicode qual HideEmptyContexts ppr_mono_ty (HsParTy _ ty) unicode qual emptyCtxts = parens (ppr_mono_lty ty unicode qual emptyCtxts) -- = parens (ppr_mono_lty ctxt_prec ty unicode qual emptyCtxts) @@ -1882,6 +1882,16 @@ ppr_mono_ty (HsWildCardTy _) _ _ _ = char '_' ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n ppr_mono_ty (XHsType HsRedacted{}) _ _ _ = error "ppr_mono_ty: HsRedacted can't be used here" +ppr_infix_ty :: LHsType DocNameI -> Qualification -> Maybe Html +ppr_infix_ty (L _ (HsTyVar _ prom op)) qual = Just pp_op_prom + where + pp_op_prom + | isPromoted prom = promoQuote pp_op + | otherwise = pp_op + pp_op = ppLDocName qual Infix op +ppr_infix_ty (L _ (HsWildCardTy _)) _ = Just (toHtml ("`_`" :: LText)) +ppr_infix_ty _ _ = Nothing + ppr_tylit :: HsLit DocNameI -> Html ppr_tylit (HsNatural _ n) = toHtml (show (il_value n)) ppr_tylit (HsString _ s) = toHtml (show s) ===================================== utils/haddock/haddock-api/src/Haddock/Convert.hs ===================================== @@ -842,7 +842,8 @@ synifyType _ boundTvs (TyConApp tc tys) = | L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy -> noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy') | otherwise -> - noLocA $ HsOpTy noExtField IsPromoted hTy (noLocA $ noUserRdr $ getName tc) tTy + let tyop = noLocA $ HsTyVar noAnn IsPromoted (noLocA $ noUserRdr $ getName tc) + in noLocA $ HsOpTy noExtField hTy tyop tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -854,9 +855,8 @@ synifyType _ boundTvs (TyConApp tc tys) = noLocA $ HsOpTy noExtField - NotPromoted (synifyType WithinType boundTvs ty1) - (noLocA $ noUserRdr eqTyConName) + (noLocA $ HsTyVar noAnn NotPromoted (noLocA $ noUserRdr eqTyConName)) (synifyType WithinType boundTvs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) @@ -864,9 +864,8 @@ synifyType _ boundTvs (TyConApp tc tys) = mk_app_tys ( HsOpTy noExtField - prom (synifyType WithinType boundTvs ty1) - (noLocA $ noUserRdr $ getName tc) + (noLocA $ HsTyVar noAnn prom (noLocA $ noUserRdr $ getName tc)) (synifyType WithinType boundTvs ty2) ) tys_rest ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -465,8 +465,8 @@ reparenTypePrec = go paren p PREC_CON $ HsAppTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ty) go p (HsAppKindTy x fun_ty arg_ki) = paren p PREC_CON $ HsAppKindTy x (goL PREC_FUN fun_ty) (goL PREC_CON arg_ki) - go p (HsOpTy x prom ty1 op ty2) = - paren p PREC_FUN $ HsOpTy x prom (goL PREC_OP ty1) op (goL PREC_OP ty2) + go p (HsOpTy x ty1 op ty2) = + paren p PREC_FUN $ HsOpTy x (goL PREC_OP ty1) op (goL PREC_OP ty2) go p (HsParTy _ t) = unXRec @a $ goL p t -- pretend the paren doesn't exist - it will be added back if needed go _ t@HsTyVar{} = t go _ t@HsStarTy{} = t ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -399,11 +399,11 @@ renameType t = case t of return (HsAppTy noAnn lhs rhs) HsTupleTy _ b ts -> return . HsTupleTy noAnn b =<< mapM renameLType ts HsSumTy _ ts -> HsSumTy noAnn <$> mapM renameLType ts - HsOpTy _ prom a (L loc op) b -> do - op' <- renameName (getName op) + HsOpTy _ a op b -> do + op' <- renameLType op a' <- renameLType a b' <- renameLType b - return (HsOpTy noAnn prom a' (L loc op') b') + return (HsOpTy noAnn a' op' b') HsParTy _ ty -> return . (HsParTy noAnn) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty ===================================== utils/haddock/haddock-api/src/Haddock/Interface/RenameType.hs ===================================== @@ -104,8 +104,8 @@ renameType (HsFunTy x w la lr) = HsFunTy x <$> renameHsMultAnn w <*> renameLType renameType (HsListTy x lt) = HsListTy x <$> renameLType lt renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt -renameType (HsOpTy x f la lop lb) = - HsOpTy x <$> pure f <*> renameLType la <*> renameLNameOcc lop <*> renameLType lb +renameType (HsOpTy x la lop lb) = + HsOpTy x <$> renameLType la <*> renameLType lop <*> renameLType lb renameType (HsParTy x lt) = HsParTy x <$> renameLType lt renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae3491b07fddfb6a8331679d4a6f4fb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae3491b07fddfb6a8331679d4a6f4fb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/floatout-verbosity-check] compiler: avoid unneeded traversals in GHC.Unit.State
by Cheng Shao (＠TerrorJack) 03 Mar '26

03 Mar '26

Cheng Shao pushed to branch wip/floatout-verbosity-check at Glasgow Haskell Compiler / GHC Commits: 8da5121c by Cheng Shao at 2026-03-02T21:42:28+00:00 compiler: avoid unneeded traversals in GHC.Unit.State Following !15591, this patch avoids unneeded traversals in `reportCycles`/`reportUnusable` when log verbosity is below given threshold. Also applies `logVerbAtLeast` when appropriate. Co-authored-by: Codex <codex(a)openai.com> - - - - - 2 changed files: - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Error.hs Changes: ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1279,7 +1279,7 @@ pprReason pref reason = case reason of nest 2 (hsep (map ppr deps)) reportCycles :: Logger -> [SCC UnitInfo] -> IO () -reportCycles logger sccs = mapM_ report sccs +reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where report (AcyclicSCC _) = return () report (CyclicSCC vs) = @@ -1288,7 +1288,7 @@ reportCycles logger sccs = mapM_ report sccs nest 2 (hsep (map (ppr . unitId) vs)) reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs) +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) where report (ipid, (_, reason)) = debugTraceMsg logger 2 $ @@ -1389,7 +1389,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> ppr db_path - when (log_verbosity (logFlags logger) >= 2) $ + when (logVerbAtLeast logger 2) $ forM_ (Set.toList override_set) $ \pkg -> debugTraceMsg logger 2 $ text "package" <+> ppr pkg <+> ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -463,7 +463,7 @@ withTiming' logger what force_result prtimings action debugTraceMsg :: Logger -> Int -> SDoc -> IO () debugTraceMsg logger val msg = - when (log_verbosity (logFlags logger) >= val) $ + when (logVerbAtLeast logger val) $ logInfo logger (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8da5121cf870d86854281e69c430847… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8da5121cf870d86854281e69c430847… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Clean up join points, casts & ticks
by Marge Bot (＠marge-bot) 03 Mar '26

03 Mar '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 08bc245b by sheaf at 2026-03-01T11:11:54-05:00 Clean up join points, casts & ticks This commit shores up the logic dealing with casts and ticks occurring in between a join point binding and a jump. Fixes #26642 #26929 #26693 Makes progress on #14610 #26157 #26422 Changes: - Remove 'GHC.Types.Tickish.TickishScoping' in favour of simpler predicates 'tickishHasNoScope'/'tickishHasSoftScope', as things were before commit 993975d3. This makes the code easier to read and document (fewer indirections). - Introduce 'canCollectArgsThroughTick' for consistent handling of ticks around PrimOps and other 'Id's that cannot be eta-reduced. See overhauled Note [Ticks and mandatory eta expansion]. - New Note [JoinId vs TailCallInfo] in GHC.Core.SimpleOpt that explains robustness of JoinId vs fragility of TailCallInfo. - Allow casts/non-soft-scoped ticks to occur in between a join point binder and a jump, but only in Core Prep. See Note [Join points, casts, and ticks] and Note [Join points, casts, and ticks... in Core Prep] in GHC.Core.Opt.Simplify.Iteration. Also update Core Lint to account for this. See Note [Linting join points with casts or ticks] in GHC.Core.Lint. - Update 'GHC.Core.Utils.mergeCaseAlts' to avoid pushing a cast in between a join point binding and its jumps. This fixes #26642. See the new (MC5) and (MC6) in Note [Merge Nested Cases]. - Update float out to properly handle source note ticks. They are now properly floated out instead of being discarded. This increases the number of ticks in certain tests with -g. Test cases: T26642 and TrickyJoins. Metric increase due to more source note ticks with -g: ------------------------- Metric Increase: libdir size_hello_artifact size_hello_unicode ------------------------- - - - - - 476c4cdf by Sean D. Gillespie at 2026-03-02T10:14:37-05:00 Add SIMD absolute value on x86 and LLVM On x86, absolute value of 32 bits or less is implemented with PABSB/PABSW/PABSD if SSSE3 is available. Otherwise, there is a fallback for SSE2. For 64 bit integers it uses VPABSQ, required by AVX-512VL, with fallbacks for SSE4.2 and SSE2. There is no dedicated instruction for floating point absolute value on x86, so it is simulated using bitwise AND. Absolute value for signed integers and floats are implemented by the "llvm.abs/llvm.fabs" standard library intrinsics. This implementation uses MachOps constructors, unlike non-vector floating point absolute value, which uses CallishMachOps. - - - - - 709448c0 by Sean D. Gillespie at 2026-03-02T10:14:46-05:00 Add SIMD floating point square root On x86, this is implemented with the SQRTPS and SQRTPD instructions. On LLVM, it uses the sqrt library intrinstic. - - - - - 0deadf66 by Sean D. Gillespie at 2026-03-02T10:14:47-05:00 Improve error message for SIMD on aarch64 When encountering vector literals on aarch64, previously it would throw: <no location info>: error: panic! (the 'impossible' happened) GHC version 9.15.20251219: getRegister' (CmmLit:CmmVec): Now it is more consistent with the other vector operations: <no location info>: error: sorry! (unimplemented feature or known bug) GHC version 9.15.20251219: SIMD operations on AArch64 currently require the LLVM backend - - - - - a1280207 by Vladislav Zavialov at 2026-03-02T16:07:36-05:00 Replace maybeAddSpace with spaceIfSingleQuote Simplify pretty-printing of HsTypes by using spaceIfSingleQuote. This allows us to drop the unwieldy lhsTypeHasLeadingPromotionQuote helper function. Follow-up to 178c1fd830c78377ef5d338406a41e1d8eb5f0da - - - - - 63 changed files: - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Cmm/MachOp.hs - compiler/GHC/Cmm/Node.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/CmmToC.hs - compiler/GHC/CmmToLlvm/CodeGen.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/FloatIn.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/StgToCmm/Expr.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Tickish.hs - libraries/base/src/GHC/Base.hs - libraries/base/src/GHC/Exts.hs - libraries/ghc-experimental/CHANGELOG.md - testsuite/tests/codeGen/should_compile/debug.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - testsuite/tests/simd/should_run/doublex2_arith.hs - testsuite/tests/simd/should_run/doublex2_arith.stdout - testsuite/tests/simd/should_run/doublex2_arith_baseline.hs - testsuite/tests/simd/should_run/doublex2_arith_baseline.stdout - testsuite/tests/simd/should_run/floatx4_arith.hs - testsuite/tests/simd/should_run/floatx4_arith.stdout - testsuite/tests/simd/should_run/floatx4_arith_baseline.hs - testsuite/tests/simd/should_run/floatx4_arith_baseline.stdout - testsuite/tests/simd/should_run/int16x8_arith.hs - testsuite/tests/simd/should_run/int16x8_arith.stdout - testsuite/tests/simd/should_run/int16x8_arith_baseline.hs - testsuite/tests/simd/should_run/int16x8_arith_baseline.stdout - testsuite/tests/simd/should_run/int32x4_arith.hs - testsuite/tests/simd/should_run/int32x4_arith.stdout - testsuite/tests/simd/should_run/int32x4_arith_baseline.hs - testsuite/tests/simd/should_run/int32x4_arith_baseline.stdout - testsuite/tests/simd/should_run/int64x2_arith.hs - testsuite/tests/simd/should_run/int64x2_arith.stdout - testsuite/tests/simd/should_run/int64x2_arith_baseline.hs - testsuite/tests/simd/should_run/int64x2_arith_baseline.stdout - testsuite/tests/simd/should_run/int8x16_arith.hs - testsuite/tests/simd/should_run/int8x16_arith.stdout - testsuite/tests/simd/should_run/int8x16_arith_baseline.hs - testsuite/tests/simd/should_run/int8x16_arith_baseline.stdout - + testsuite/tests/simplCore/should_compile/T26642.hs - + testsuite/tests/simplCore/should_compile/TrickyJoins.hs - testsuite/tests/simplCore/should_compile/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77b48b37fa767a00d747419c0483af… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/77b48b37fa767a00d747419c0483af… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/longpath-aware-manifest] Add `-fwin-aware-long-paths` to support ling paths on Windows
by Hannes Siebenhandl (＠fendor) 03 Mar '26

03 Mar '26

Hannes Siebenhandl pushed to branch wip/fendor/longpath-aware-manifest at Glasgow Haskell Compiler / GHC Commits: e23169ef by Fendor at 2026-03-02T21:37:51+01:00 Add `-fwin-aware-long-paths` to support ling paths on Windows While Windows supports file paths longer than the MAX_PATH restriction, it is opt-in, and not enabled by default. By declaring the binary to be long path aware in the manifest of the windows executable, the binary opts-in to the new behaviour. It is up to the developer to make sure they use UNC paths and Win.h specific functions for filesystem operations to use long paths in their application. See https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-li… and https://learn.microsoft.com/en-us/windows/win32/sbscs/application-manifests for the documentation on the application manifest and long path option. - - - - - 5 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Linker/Windows.hs - docs/users_guide/phases.rst Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -1210,6 +1210,7 @@ defaultFlags settings = [ Opt_AutoLinkPackages, Opt_DiagnosticsShowCaret, Opt_EmbedManifest, + Opt_WinLongPathAware, Opt_FamAppCache, Opt_GenManifest, Opt_GhciHistory, ===================================== compiler/GHC/Driver/Flags.hs ===================================== @@ -744,6 +744,7 @@ data GeneralFlag | Opt_PrintBindContents | Opt_GenManifest | Opt_EmbedManifest + | Opt_WinLongPathAware | Opt_SharedImplib | Opt_BuildingCabalPackage | Opt_IgnoreDotGhci ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -2525,6 +2525,7 @@ fFlagsDeps = [ flagSpec "eager-blackholing" Opt_EagerBlackHoling, flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "win-aware-long-paths" Opt_WinLongPathAware, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, ===================================== compiler/GHC/Linker/Windows.hs ===================================== @@ -16,6 +16,7 @@ import System.Directory data ManifestOpts = ManifestOpts { manifestEmbed :: !Bool -- ^ Should the manifest be embedded in the binary with Windres + , manifestLongPathAware :: !Bool , manifestTempdir :: TempDir , manifestWindresConfig :: WindresConfig , manifestObjectSuf :: String @@ -24,6 +25,7 @@ data ManifestOpts = ManifestOpts initManifestOpts :: DynFlags -> ManifestOpts initManifestOpts dflags = ManifestOpts { manifestEmbed = gopt Opt_EmbedManifest dflags + , manifestLongPathAware = gopt Opt_WinLongPathAware dflags , manifestTempdir = tmpDir dflags , manifestWindresConfig = configureWindres dflags , manifestObjectSuf = objectSuf dflags @@ -37,21 +39,7 @@ maybeCreateManifest -> IO [FilePath] -- ^ extra objects to embed, maybe maybeCreateManifest logger tmpfs opts exe_filename = do let manifest_filename = exe_filename <.> "manifest" - manifest = - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ - \ <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\ - \ <assemblyIdentity version=\"1.0.0.0\"\n\ - \ processorArchitecture=\"X86\"\n\ - \ name=\"" ++ dropExtension exe_filename ++ "\"\n\ - \ type=\"win32\"/>\n\n\ - \ <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\ - \ <security>\n\ - \ <requestedPrivileges>\n\ - \ <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\ - \ </requestedPrivileges>\n\ - \ </security>\n\ - \ </trustInfo>\n\ - \</assembly>\n" + manifest = manifestContents (manifestLongPathAware opts) exe_filename writeFile manifest_filename manifest @@ -80,3 +68,36 @@ maybeCreateManifest logger tmpfs opts exe_filename = do removeFile manifest_filename return [rc_obj_filename] + +manifestContents :: Bool -> FilePath -> String +manifestContents longPathAware exe_filename = + unlines $ + [ "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>" + , " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">" + , " <assemblyIdentity version=\"1.0.0.0\"" + , " processorArchitecture=\"X86\"" + , " name=\"" ++ dropExtension exe_filename ++ "\"" + , " type=\"win32\"/>" + , " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">" + , " <security>" + , " <requestedPrivileges>" + , " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>" + , " </requestedPrivileges>" + , " </security>" + , " </trustInfo>" + ] + ++ + ( + if longPathAware + then + [ " <application xmlns=\"urn:schemas-microsoft-com:asm.v3\">" + , " <windowsSettings xmlns:ws2=\"http://schemas.microsoft.com/SMI/2016/WindowsSettings\">" + , " <ws2:longPathAware>true</ws2:longPathAware>" + , " </windowsSettings>" + , " </application>" + ] + else + [] + ) ++ + [ " </assembly>" + ] ===================================== docs/users_guide/phases.rst ===================================== @@ -1430,6 +1430,29 @@ for example). See also :ghc-flag:`-pgmwindres ⟨cmd⟩` (:ref:`replacing-phases`) and :ghc-flag:`-optwindres ⟨option⟩` (:ref:`forcing-options-through`). +.. ghc-flag:: -fwin-aware-long-paths + :shortdesc: Declare the linked binary to be long path aware on Windows. + :reverse: -fno-win-aware-long-paths + :type: dynamic + :category: linking + :since: 9.14.2 + + Declare in the manifest file that GHC generates when linking a binary on Windows + to be aware of long paths. + + Windows paths usually have a `MAX_PATH <https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-li…>`__ + limit of 260 characters. + This limitation can be lifted by opting into enabling long paths in various + ways, see `Enable long paths in Windows 10 and later`_. + + To invoke the compiled program with long paths, the Windows manifest needs + to declare that the program is aware of long paths and can handle them + appropriately. + + :ghc-flag:`-fno-embed-manifest` also implies :ghc-flag:`-fno-win-aware-long-paths`. + + _Enable long paths in Windows 10 and later: https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-li… + .. ghc-flag:: -fno-shared-implib :shortdesc: Don't generate an import library for a DLL (Windows only) :type: dynamic View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e23169efcda88936d05b0660b066645… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e23169efcda88936d05b0660b066645… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/floatout-verbosity-check
by Cheng Shao (＠TerrorJack) 03 Mar '26

03 Mar '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/fix-head
by Cheng Shao (＠TerrorJack) 03 Mar '26

03 Mar '26

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

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/div_test
by Andreas Klebinger (＠AndreasK) 03 Mar '26

03 Mar '26

Andreas Klebinger pushed new branch wip/andreask/div_test at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/div_test You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26971] Adding WIP decoupling of L.H.S and GHC.Hs.Doc
by recursion-ninja (＠recursion-ninja) 02 Mar '26

02 Mar '26

recursion-ninja pushed to branch wip/fix-26971 at Glasgow Haskell Compiler / GHC Commits: 273fba40 by Recursion Ninja at 2026-03-02T09:19:17-05:00 Adding WIP decoupling of L.H.S and GHC.Hs.Doc - - - - - 19 changed files: - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Extension.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - + compiler/Language/Haskell/Syntax/UTF8.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Hs/Basic.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Prelude import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Types.Name -import GHC.Parser.Annotation +--import GHC.Parser.Annotation import GHC.Utils.Misc ((<||>)) import Data.Data (Data) @@ -86,8 +86,8 @@ instance Binary FixityDirection where -- @ data NamespaceSpecifier = NoNamespaceSpecifier - | TypeNamespaceSpecifier (EpToken "type") - | DataNamespaceSpecifier (EpToken "data") + | TypeNamespaceSpecifier () -- (EpToken "type") + | DataNamespaceSpecifier () --(EpToken "data") deriving (Eq, Data) -- | Check if namespace specifiers overlap, i.e. if they are equal or ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set import GHC.Driver.Flags +import GHC.Parser.Annotation import Control.DeepSeq import Data.Data @@ -49,29 +50,15 @@ import Data.Function import GHC.Hs.DocString +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name --- | A docstring with the (probable) identifiers found in it. -type HsDoc = WithHsDocIdentifiers HsDocString +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcPs) +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcRn) +deriving instance Eq a => Eq (WithHsDocIdentifiers a GhcTc) --- | Annotate a value with the probable identifiers found in it --- These will be used by haddock to generate links. --- --- The identifiers are bundled along with their location in the source file. --- This is useful for tooling to know exactly where they originate. --- --- This type is currently used in two places - for regular documentation comments, --- with 'a' set to 'HsDocString', and for adding identifier information to --- warnings, where 'a' is 'StringLiteral' -data WithHsDocIdentifiers a pass = WithHsDocIdentifiers - { hsDocString :: !a - , hsDocIdentifiers :: ![Located (IdP pass)] - } - -deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) -deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) -instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where +instance (NFData (LIdP (GhcPass pass)), NFData a) => NFData (WithHsDocIdentifiers a (GhcPass pass)) where rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i -- | For compatibility with the existing @-ddump-parsed' output, we only show @@ -81,12 +68,26 @@ instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) w instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where ppr (WithHsDocIdentifiers s _ids) = ppr s -instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where +{- +instance forall a . (Binary a, Binary (Anno Name)) => Binary (WithHsDocIdentifiers a (GhcRn)) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh $ BinLocated <$> (sortBy (stableNameCmp `on` getName) ids) + put_ bh $ BinGenLocated <$> ids +-- put_ bh ids get bh = - liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) + liftA2 (WithHsDocIdentifiers :: a -> [LIdP (GhcPass p)] -> WithHsDocIdentifiers a (GhcPass p)) (get bh) (fmap unBinGenLocated <$> get bh) +-} +{- +ids = [GenLocated (Anno Name) Name] + = [GenLocated (SrcSpanAnnN) Name] + = [GenLocated (EpAnn NameAnn) Name] + + +[LIdP GhcRn] = [XRec GhcRn (IdP GhcRn)] + = [XRec GhcRn (IdGhcP 'Renamed)] + = [XRec GhcRn Name] +-} + -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to. @@ -98,22 +99,21 @@ hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids -- and will come either before or after depending on how it was written -- i.e it will come after the thing if it is a '-- ^' or '{-^' and before -- otherwise. -pprWithDoc :: LHsDoc name -> SDoc -> SDoc +pprWithDoc :: LHsDoc (GhcPass name) -> SDoc -> SDoc pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) -- | See 'pprWithHsDoc' -pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc +pprMaybeWithDoc :: Maybe (LHsDoc (GhcPass name)) -> SDoc -> SDoc pprMaybeWithDoc Nothing = id pprMaybeWithDoc (Just doc) = pprWithDoc doc -- | Print a doc with its identifiers, useful for debugging -pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc +pprHsDocDebug :: HsDoc (GhcPass name) -> SDoc pprHsDocDebug (WithHsDocIdentifiers s ids) = vcat [ text "text:" $$ nest 2 (pprHsDocString s) - , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) +-- , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids)) ] - -type LHsDoc pass = Located (HsDoc pass) +-- XRec p (IdP p) -- | A simplified version of 'HsImpExp.IE'. data DocStructureItem @@ -136,6 +136,7 @@ data DocStructureItem -- ^ Invariant: This list of Avails must be sorted -- to guarantee interface file determinism. +{- instance Binary DocStructureItem where put_ bh = \case DsiSectionHeading level doc -> do @@ -165,6 +166,7 @@ instance Binary DocStructureItem where 3 -> DsiExports <$> get bh 4 -> DsiModExport <$> get bh <*> get bh _ -> fail "instance Binary DocStructureItem: Invalid tag" +-} instance Outputable DocStructureItem where ppr = \case @@ -185,8 +187,8 @@ instance Outputable DocStructureItem where instance NFData DocStructureItem where rnf = \case - DsiSectionHeading level doc -> rnf level `seq` rnf doc - DsiDocChunk doc -> rnf doc + DsiSectionHeading level !doc -> rnf level -- `seq` rnf doc + DsiDocChunk !doc -> () -- rnf doc DsiNamedChunkRef name -> rnf name DsiExports avails -> rnf avails DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails @@ -220,10 +222,16 @@ data Docs = Docs instance NFData Docs where rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions) +{- = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions `seq` () +-} + = rnf structure + `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions + `seq` () +{- instance Binary Docs where put_ bh docs = do put_ bh (docs_mod_hdr docs) @@ -255,6 +263,7 @@ instance Binary Docs where , docs_language = language , docs_extensions = exts } +-} instance Outputable Docs where ppr docs = ===================================== compiler/GHC/Hs/Doc.hs-boot deleted ===================================== @@ -1,18 +0,0 @@ -module GHC.Hs.Doc where - --- See #21592 for progress on removing this boot file. - -import GHC.Types.SrcLoc -import GHC.Hs.DocString -import Data.Kind - -type role WithHsDocIdentifiers representational nominal -type WithHsDocIdentifiers :: Type -> Type -> Type -data WithHsDocIdentifiers a pass - -type HsDoc :: Type -> Type -type HsDoc = WithHsDocIdentifiers HsDocString - -type LHsDoc :: Type -> Type -type LHsDoc pass = Located (HsDoc pass) - ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -1,8 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + -- | An exactprintable structure for docstrings module GHC.Hs.DocString ( LHsDocString , HsDocString(..) + , HsDocStringGhc , HsDocStringDecorator(..) , HsDocStringChunk(..) , LHsDocStringChunk @@ -23,6 +26,8 @@ module GHC.Hs.DocString import GHC.Prelude +import GHC.Hs.Extension + import GHC.Utils.Binary import GHC.Utils.Encoding import GHC.Utils.Outputable as Outputable hiding ((<>)) @@ -34,9 +39,16 @@ import qualified Data.ByteString as BS import Data.Data import Data.List.NonEmpty (NonEmpty(..)) import Data.List (intercalate) +import Data.Void + +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension + +type LHsDocString pass = Located (HsDocString pass) -type LHsDocString = Located HsDocString +type HsDocStringGhc = HsDocString Void +{- -- | Haskell Documentation String -- -- Rich structure to support exact printing @@ -56,62 +68,81 @@ data HsDocString -- This is because it may contain unbalanced pairs of '{-' and '-}' and -- not form a valid 'NestedDocString' deriving (Eq, Data, Show) +-} -instance Outputable HsDocString where - ppr = text . renderHsDocString +type instance XMultiLineDocString (GhcPass p) = NoExtField +type instance XNestedDocString (GhcPass p) = NoExtField +type instance XGeneratedDocString (GhcPass p) = NoExtField +type instance XXHsDocString (GhcPass p) = DataConCantHappen +{- instance NFData HsDocString where rnf (MultiLineDocString a b) = rnf a `seq` rnf b rnf (NestedDocString a b) = rnf a `seq` rnf b rnf (GeneratedDocString a) = rnf a +-} +deriving stock instance Eq (HsDocString (GhcPass pass)) +-- deriving stock instance Show (HsDocString (GhcPass pass)) --- | Annotate a pretty printed thing with its doc --- The docstring comes after if is 'HsDocStringPrevious' --- Otherwise it comes before. --- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext --- because we can't control if something else will be pretty printed on the same line -pprWithDocString :: HsDocString -> SDoc -> SDoc -pprWithDocString (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd -pprWithDocString doc@(NestedDocString HsDocStringPrevious _) sd = sd <+> pprHsDocString doc -pprWithDocString doc sd = pprHsDocString doc $+$ sd - - -instance Binary HsDocString where +instance Binary (HsDocString (GhcPass p)) where put_ bh x = case x of - MultiLineDocString dec xs -> do + MultiLineDocString _ dec xs -> do putByte bh 0 put_ bh dec put_ bh $ BinLocated <$> xs - NestedDocString dec x -> do + NestedDocString _ dec x -> do putByte bh 1 put_ bh dec put_ bh $ BinLocated x - GeneratedDocString x -> do + GeneratedDocString _ x -> do putByte bh 2 put_ bh x get bh = do tag <- getByte bh case tag of - 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) - 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) - 2 -> GeneratedDocString <$> get bh + 0 -> MultiLineDocString NoExtField <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString NoExtField <$> get bh <*> (unBinLocated <$> get bh) + 2 -> GeneratedDocString NoExtField <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t +instance NFData (HsDocString (GhcPass pass)) where + rnf = \case + MultiLineDocString NoExtField a b -> rnf a `seq` rnf b + NestedDocString NoExtField a b -> rnf a `seq` rnf b + GeneratedDocString NoExtField a -> rnf a + +instance Outputable (HsDocString (GhcPass p)) where + ppr = text . renderHsDocString + +-- | Annotate a pretty printed thing with its doc +-- The docstring comes after if is 'HsDocStringPrevious' +-- Otherwise it comes before. +-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext +-- because we can't control if something else will be pretty printed on the same line +pprWithDocString :: HsDocString (GhcPass p) -> SDoc -> SDoc +pprWithDocString (MultiLineDocString x HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString x HsDocStringNext ds) sd +pprWithDocString doc@(NestedDocString _ HsDocStringPrevious _) sd = sd <+> pprHsDocString doc +pprWithDocString doc sd = pprHsDocString doc $+$ sd + +{- data HsDocStringDecorator = HsDocStringNext -- ^ '|' is the decorator | HsDocStringPrevious -- ^ '^' is the decorator | HsDocStringNamed !String -- ^ '$<string>' is the decorator | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s deriving (Eq, Ord, Show, Data) +-} instance Outputable HsDocStringDecorator where ppr = text . printDecorator +{- instance NFData HsDocStringDecorator where rnf HsDocStringNext = () rnf HsDocStringPrevious = () rnf (HsDocStringNamed x) = rnf x rnf (HsDocStringGroup x) = rnf x +-} printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" @@ -134,20 +165,26 @@ instance Binary HsDocStringDecorator where 3 -> HsDocStringGroup <$> get bh t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t +{- type LHsDocStringChunk = Located HsDocStringChunk -- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString deriving stock (Eq,Ord,Data, Show) deriving newtype (NFData) +-} + +type instance Anno HsDocStringChunk = SrcSpan instance Binary HsDocStringChunk where put_ bh (HsDocStringChunk bs) = put_ bh bs get bh = HsDocStringChunk <$> get bh + instance Outputable HsDocStringChunk where ppr = text . unpackHDSC +{- mkHsDocStringChunk :: String -> HsDocStringChunk mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s) @@ -163,41 +200,42 @@ nullHDSC (HsDocStringChunk bs) = BS.null bs mkGeneratedHsDocString :: String -> HsDocString mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk +-} -isEmptyDocString :: HsDocString -> Bool -isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs -isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s -isEmptyDocString (GeneratedDocString x) = nullHDSC x +isEmptyDocString :: HsDocString (GhcPass p) -> Bool +isEmptyDocString (MultiLineDocString _ _ xs) = all (nullHDSC . unLoc) xs +isEmptyDocString (NestedDocString _ _ s) = nullHDSC $ unLoc s +isEmptyDocString (GeneratedDocString _ x) = nullHDSC x -docStringChunks :: HsDocString -> [LHsDocStringChunk] -docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs -docStringChunks (NestedDocString _ x) = [x] -docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] +docStringChunks :: HsDocString (GhcPass p) -> [LHsDocStringChunk (GhcPass p)] +docStringChunks (MultiLineDocString _ _ (x:|xs)) = x:xs +docStringChunks (NestedDocString _ _ x) = [x] +docStringChunks (GeneratedDocString _ x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] -- | Pretty print with decorators, exactly as the user wrote it -pprHsDocString :: HsDocString -> SDoc +pprHsDocString :: HsDocString (GhcPass p) -> SDoc pprHsDocString = text . exactPrintHsDocString -pprHsDocStrings :: [HsDocString] -> SDoc +pprHsDocStrings :: [HsDocString (GhcPass p)] -> SDoc pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString -- | Pretty print with decorators, exactly as the user wrote it -exactPrintHsDocString :: HsDocString -> String -exactPrintHsDocString (MultiLineDocString dec (x :| xs)) +exactPrintHsDocString :: HsDocString (GhcPass p) -> String +exactPrintHsDocString (MultiLineDocString _ dec (x :| xs)) = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x)) : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs -exactPrintHsDocString (NestedDocString dec (L _ s)) +exactPrintHsDocString (NestedDocString _ dec (L _ s)) = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}" -exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of +exactPrintHsDocString (GeneratedDocString _ x) = case lines (unpackHDSC x) of [] -> "" (x:xs) -> unlines' $ ( "-- |" ++ x) : map (\y -> "--"++y) xs -- | Just get the docstring, without any decorators -renderHsDocString :: HsDocString -> String -renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs) -renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds -renderHsDocString (GeneratedDocString x) = unpackHDSC x +renderHsDocString :: HsDocString (GhcPass p) -> String +renderHsDocString (MultiLineDocString _ _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs) +renderHsDocString (NestedDocString _ _ ds) = unpackHDSC $ unLoc ds +renderHsDocString (GeneratedDocString _ x) = unpackHDSC x -- | Don't add a newline to a single string unlines' :: [String] -> String @@ -205,5 +243,5 @@ unlines' = intercalate "\n" -- | Just get the docstring, without any decorators -- Separates docstrings using "\n\n", which is how haddock likes to render them -renderHsDocStrings :: [HsDocString] -> String +renderHsDocStrings :: [HsDocString (GhcPass p)] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString ===================================== compiler/GHC/Hs/Extension.hs ===================================== @@ -21,7 +21,7 @@ import GHC.Types.Var import GHC.Utils.Outputable hiding ((<>)) import GHC.Types.SrcLoc (GenLocated(..), unLoc) import GHC.Utils.Panic -import GHC.Parser.Annotation +--import GHC.Parser.Annotation {- Note [IsPass] @@ -92,16 +92,18 @@ type instance XRec (GhcPass p) a = XRecGhc a -- but pass-independent, source location type XRecGhc a = GenLocated (Anno a) a -type instance Anno RdrName = SrcSpanAnnN -type instance Anno Name = SrcSpanAnnN -type instance Anno Id = SrcSpanAnnN +--type instance Anno RdrName = SrcSpanAnnN +--type instance Anno Name = SrcSpanAnnN +--type instance Anno Id = SrcSpanAnnN type instance Anno (WithUserRdr a) = Anno a +{- type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, Anno (IdOccGhcP p) ~ EpAnn a, NoAnn a, IsPass p) +-} instance UnXRec (GhcPass p) where unXRec = unLoc ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Hs.ImpExp , module GHC.Hs.ImpExp ) where +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp @@ -39,7 +40,6 @@ import GHC.Unit.Module.Warnings import Data.Data import Data.Maybe -import GHC.Hs.Doc (LHsDoc) {- @@ -144,6 +144,10 @@ simpleImportDecl mn = ImportDecl { } instance (OutputableBndrId p + , Outputable + (GenLocated + (Anno (WithHsDocIdentifiers (HsDocString (GhcPass p)) (GhcPass p))) + (WithHsDocIdentifiers (HsDocString (GhcPass p)) (GhcPass p))) , Outputable (Anno (IE (GhcPass p))) , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where @@ -353,10 +357,10 @@ replaceWrappedName (IEData r (L l _)) n = IEData r (L l n) replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') -exportDocstring :: LHsDoc pass -> SDoc +exportDocstring :: Outputable (LHsDoc (GhcPass p)) => LHsDoc (GhcPass p) -> SDoc exportDocstring doc = braces (text "docstring: " <> ppr doc) -instance OutputableBndrId p => Outputable (IE (GhcPass p)) where +instance (OutputableBndrId p, Outputable (LHsDoc (GhcPass p))) => Outputable (IE (GhcPass p)) where ppr ie@(IEVar _ var doc) = sep $ catMaybes [ ppr <$> ieDeprecation ie , Just $ ppr (unLoc var) ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Data.BooleanFormula (BooleanFormula(..)) import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Decls.Foreign (CType(..), Header(..)) import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) +import Language.Haskell.Syntax.Doc (HsDocString(..), WithHsDocIdentifiers(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) @@ -629,9 +630,9 @@ deriving instance Eq (IEWholeNamespaceExt GhcRn) deriving instance Eq (IEWholeNamespaceExt GhcTc) -- deriving instance (DataId name) => Data (IE name) -deriving instance Data (IE GhcPs) -deriving instance Data (IE GhcRn) -deriving instance Data (IE GhcTc) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcPs) GhcPs)) => Data (IE GhcPs) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcRn) GhcRn)) => Data (IE GhcRn) +deriving instance Data (Anno (WithHsDocIdentifiers (HsDocString GhcTc) GhcTc)) => Data (IE GhcTc) -- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) deriving instance Eq (IE GhcPs) @@ -669,3 +670,13 @@ deriving instance Data (InlinePragma GhcTc) deriving instance Data (OverlapMode GhcPs) deriving instance Data (OverlapMode GhcRn) deriving instance Data (OverlapMode GhcTc) + + +-- deriving instance Data (HsDocString p) +deriving instance Data (HsDocString GhcPs) +deriving instance Data (HsDocString GhcRn) +deriving instance Data (HsDocString GhcTc) + +deriving instance Data a => Data (WithHsDocIdentifiers a GhcPs) +deriving instance Data a => Data (WithHsDocIdentifiers a GhcRn) +deriving instance Data a => Data (WithHsDocIdentifiers a GhcTc) ===================================== compiler/GHC/Hs/Lit.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type +import GHC.Parser.Annotation ( {- type instance Anno Id -} ) import GHC.Utils.Misc (split) import GHC.Utils.Outputable import GHC.Utils.Panic (panic) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -668,7 +668,7 @@ fromIfaceWarningTxt = \case IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn -fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) +fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module GHC.Parser.Annotation ( -- * Core Exact Print Annotation types EpToken(..), EpUniToken(..), @@ -32,6 +34,7 @@ module GHC.Parser.Annotation ( SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, LocatedE, + IsSrcSpanAnn, -- ** Annotation data types used in 'GenLocated' @@ -94,17 +97,34 @@ import Data.Data import Data.Function (on) import Data.List (sortBy) import Data.Semigroup +import Data.Void import GHC.Data.FastString import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import GHC.Types.Name +import GHC.Types.Name.Reader (RdrName) import GHC.Types.SrcLoc -import GHC.Hs.DocString +--import GHC.Hs.DocString +import GHC.Types.Var (Id) import GHC.Utils.Misc import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict import GHC.Types.SourceText (SourceText (NoSourceText)) +import GHC.Hs.Extension + +import Language.Haskell.Syntax.Doc +import Language.Haskell.Syntax.Extension (Anno) + +type instance Anno Id = SrcSpanAnnN +type instance Anno Name = SrcSpanAnnN +type instance Anno RdrName = SrcSpanAnnN + +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, + Anno (IdOccGhcP p) ~ EpAnn a, + NoAnn a, + IsPass p) + {- Note [exact print annotations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -308,18 +328,46 @@ data EpaComment = -- and the start of this location is used for the spacing when -- exact printing the comment. } - deriving (Eq, Data, Show) + deriving (Eq, Show) + +instance Data EpaComment where + gunfold _ _ _ = undefined + toConstr = undefined + dataTypeOf = undefined data EpaCommentTok = -- Documentation annotations - EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString + EpaDocComment (HsDocString Void) -- ^ a docstring that can be pretty printed using pprHsDocString | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) | EpaLineComment String -- ^ comment starting by "--" | EpaBlockComment String -- ^ comment in {- -} - deriving (Eq, Data, Show) + deriving (Eq, Show) + -- TODO: add back the Data and Show instance -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop +instance {-# OVERLAPPING #-} Eq (HsDocString Void) where + (==) = \case + MultiLineDocString _ a1 b1 -> \case + MultiLineDocString _ a2 b2 -> a1 == a2 && length b1 == length b2 + _ -> False + NestedDocString _ a1 b1 -> \case + NestedDocString _ a2 b2 -> a1 == a2 + _ -> False + GeneratedDocString _ a1 -> \case + GeneratedDocString _ a2 -> a1 == a2 + _ -> False + XHsDocString _ -> \case + XHsDocString _ -> True + _ -> False + +instance {-# OVERLAPPING #-} Show (HsDocString Void) where + show = \case + MultiLineDocString _ a b -> unwords ["MultiLineDocString", show a ] + NestedDocString _ a b -> unwords ["NestedDocString" , show a ] + GeneratedDocString _ a -> unwords ["GeneratedDocString", show a ] + XHsDocString _ -> "XHsDocString" + instance Outputable EpaComment where ppr x = text (show x) @@ -390,7 +438,6 @@ data EpAnn ann deriving (Data, Eq, Functor) -- See Note [XRec and Anno in the AST] - spanAsAnchor :: SrcSpan -> (EpaLocation' a) spanAsAnchor ss = EpaSpan ss @@ -537,7 +584,7 @@ data AnnList a al_trailing :: ![TrailingAnn] -- ^ items appearing after the -- list, such as '=>' for a -- context - } deriving (Data,Eq) + } deriving (Data, Eq) data AnnListBrackets = ListParens (EpToken "(") (EpToken ")") @@ -570,7 +617,6 @@ data AnnContext ac_close :: [EpToken ")"] -- ^ zero or more closing parentheses. } deriving (Data) - -- --------------------------------------------------------------------- -- Annotations for names -- --------------------------------------------------------------------- @@ -648,7 +694,7 @@ data AnnPragma apr_loc2 :: EpaLocation, apr_type :: EpToken "type", apr_module :: EpToken "module" - } deriving (Data,Eq) + } deriving (Data, Eq) -- --------------------------------------------------------------------- ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -150,6 +150,10 @@ import qualified Data.Map.Strict as Map import qualified Data.Semigroup as S import System.IO.Unsafe ( unsafePerformIO ) +import Language.Haskell.Syntax.Extension + + + {- ************************************************************************ * * ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -103,7 +103,7 @@ module GHC.Utils.Binary getGenericSymtab, putGenericSymTab, getGenericSymbolTable, putGenericSymbolTable, -- * Newtype wrappers - BinSpan(..), BinSrcSpan(..), BinLocated(..), + BinSpan(..), BinSrcSpan(..), BinLocated(..), BinGenLocated(..), -- * Newtypes for types that have canonically more than one valid encoding BindingName(..), simpleBindingNameWriter, @@ -121,6 +121,7 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Module.Name (ModuleName(..)) import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) +import Language.Haskell.Syntax.UTF8 import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString @@ -1905,6 +1906,18 @@ instance Binary a => Binary (BinLocated a) where x <- get bh return $ BinLocated (L l x) +newtype BinGenLocated l a = BinGenLocated { unBinGenLocated :: GenLocated l a } + +instance (Binary a, Binary l) => Binary (BinGenLocated l a) where + put_ bh (BinGenLocated (L l x)) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return $ BinGenLocated (L l x) + newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } -- See Note [Source Location Wrappers] @@ -2097,3 +2110,8 @@ instance Binary RuleMatchInfo where h <- getByte bh if h == 1 then pure ConLike else pure FunLike + +instance Binary TextUTF8 where + put_ bh = putSBS bh . bytesUTF8 + + get = fmap unsafeFromShortByteString . getSBS ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -116,6 +116,7 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import Language.Haskell.Syntax.UTF8 import GHC.Prelude.Basic @@ -2036,3 +2037,6 @@ instance Outputable (OverlapMode p) where ppr (Incoherent _) = text "[incoherent]" ppr (NonCanonical _) = text "[noncanonical]" ppr (XOverlapMode _) = text "[user TTG extension]" + +instance Outputable TextUTF8 where + ppr = text . decodeUTF8 ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -1410,7 +1410,7 @@ data DocDecl pass | DocCommentNamed String (LHsDoc pass) | DocGroup Int (LHsDoc pass) -deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) +--deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d ===================================== compiler/Language/Haskell/Syntax/Doc.hs ===================================== @@ -0,0 +1,172 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- +## Migrate and restructure `LHsDoc` + +[X] 1. Create a new **`L.H.S.Doc`** module and move the following into it. +[X] 2. Move `HsDoc` *(no change)* +[X] 3. Move `HsDocStringChunk` *(no change)* +[X] 4. Move `HsDocStringDecorator` *(no change)* +[_] 5. Move `LHsDoc p` as `XRec p (HsDoc p)` +[X] 6. Move `WithHsDocIdentifiers p` as `Located (IdP p) as LIdP p` +[_] 7. Move `HsDocString`, adding TTG parameter and extension point +[X] 8. Move `LHsDocStringChunk = Located HsDocStringChunk` as `type LHsDocStringChunk pass = XRec pass HsDocStringChunk` +[ ] 9. Add `type instance Anno HsDocStringChunk = SrcSpan` +-} + +{- | +Data-types describing the raw and lexical docstrings of +the Haskell programming language. +-} +module Language.Haskell.Syntax.Doc + ( HsDoc + , WithHsDocIdentifiers(..) + + , HsDocString(..) + -- ** Construcction + , mkGeneratedHsDocString + + , HsDocStringChunk(..) + -- ** Construction + , mkHsDocStringChunk + , mkHsDocStringChunkUtf8ByteString + -- ** Deconstruction + , unpackHDSC + -- ** Query + , nullHDSC + + , HsDocStringDecorator(..) + , LHsDoc + , LHsDocStringChunk + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS +import Data.Data +import Data.Kind (Type) +import Data.Eq +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Function +import Prelude +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.UTF8 + +-- | A docstring with the (probable) identifiers found in it. +type HsDoc (pass :: Type) = WithHsDocIdentifiers (HsDocString pass) pass + +-- | Haskell Documentation String +-- +-- Rich structure to support exact printing +-- The location around each chunk doesn't include the decorators +data HsDocString pass + = MultiLineDocString + !(XMultiLineDocString pass) + !HsDocStringDecorator + !(NonEmpty (LHsDocStringChunk pass)) + -- ^ The first chunk is preceded by "-- <decorator>" and each following chunk is preceded by "--" + -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included + -- -- This continues that docstring and is the second element in the NonEmpty list + -- foo :: a -> a + | NestedDocString + !(XNestedDocString pass) + !HsDocStringDecorator + (LHsDocStringChunk pass) + -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}" + -- The chunk contains balanced pairs of '{-' and '-}' + | GeneratedDocString + !(XGeneratedDocString pass) + HsDocStringChunk + -- ^ A docstring generated either internally or via TH + -- Pretty printed with the '-- |' decorator + -- This is because it may contain unbalanced pairs of '{-' and '-}' and + -- not form a valid 'NestedDocString' + | XHsDocString + !(XXHsDocString pass) +{- +deriving stock instance ( + Eq (XMultiLineDocString pass), + Eq (XNestedDocString pass), + Eq (XGeneratedDocString pass), + Eq (XXHsDocString pass), + Eq (XRec pass HsDocStringChunk), + Typeable pass + ) => Eq (HsDocString pass) + +deriving stock instance ( + Show (XMultiLineDocString pass), + Show (XNestedDocString pass), + Show (XGeneratedDocString pass), + Show (XXHsDocString pass), + Show (XRec pass HsDocStringChunk), + Typeable pass + ) => Show (HsDocString pass) + +instance {-# OVERLAPPABLE #-} ( + NFData (XMultiLineDocString pass), + NFData (XNestedDocString pass), + NFData (XGeneratedDocString pass), + NFData (XXHsDocString pass), + NFData (XRec pass HsDocStringChunk) + ) => NFData (HsDocString pass) where + rnf = \case + MultiLineDocString x a b -> rnf x `seq` rnf a `seq` rnf b + NestedDocString x a b -> rnf x `seq` rnf a `seq` rnf b + GeneratedDocString x a -> rnf x `seq` rnf a + XHsDocString x -> rnf x +-} +mkGeneratedHsDocString :: XGeneratedDocString p -> String -> HsDocString p +mkGeneratedHsDocString x = GeneratedDocString x . mkHsDocStringChunk + +type LHsDoc pass = XRec pass (HsDoc pass) +--type LHsDoc pass = Located (HsDoc pass) +--type LIdP p = XRec p (IdP p) + +type LHsDocStringChunk pass = XRec pass HsDocStringChunk + +-- | A contiguous chunk of documentation +newtype HsDocStringChunk = HsDocStringChunk TextUTF8 + deriving stock (Eq,Ord,Data, Show) + deriving newtype (NFData) + +mkHsDocStringChunk :: String -> HsDocStringChunk +mkHsDocStringChunk = HsDocStringChunk . encodeUTF8 + +mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk +mkHsDocStringChunkUtf8ByteString = + HsDocStringChunk . unsafeFromShortByteString . SBS.toShort + +unpackHDSC :: HsDocStringChunk -> String +unpackHDSC (HsDocStringChunk bs) = decodeUTF8 bs + +nullHDSC :: HsDocStringChunk -> Bool +nullHDSC (HsDocStringChunk bs) = headUTF8 bs == Nothing + +data HsDocStringDecorator + = HsDocStringNext -- ^ '|' is the decorator + | HsDocStringPrevious -- ^ '^' is the decorator + | HsDocStringNamed !String -- ^ '$<string>' is the decorator + | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s + deriving (Eq, Ord, Show, Data) + +instance NFData HsDocStringDecorator where + rnf HsDocStringNext = () + rnf HsDocStringPrevious = () + rnf (HsDocStringNamed x) = rnf x + rnf (HsDocStringGroup x) = rnf x + +-- | Annotate a value with the probable identifiers found in it +-- These will be used by haddock to generate links. +-- +-- The identifiers are bundled along with their location in the source file. +-- This is useful for tooling to know exactly where they originate. +-- +-- This type is currently used in two places - for regular documentation comments, +-- with 'a' set to 'HsDocString', and for adding identifier information to +-- warnings, where 'a' is 'StringLiteral' +data WithHsDocIdentifiers a pass = WithHsDocIdentifiers + { hsDocString :: !a + , hsDocIdentifiers :: ![LIdP pass] + } ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -646,6 +646,13 @@ type family XXLit x type family XOverLit x type family XXOverLit x +-- ------------------------------------- +-- Type families for the HsDocString extension points +type family XMultiLineDocString x +type family XNestedDocString x +type family XGeneratedDocString x +type family XXHsDocString x + -- ===================================================================== -- Type families for the HsPat extension points ===================================== compiler/Language/Haskell/Syntax/ImpExp.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where +import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) @@ -13,7 +14,7 @@ import Data.String (String) import Data.Int (Int) import Control.DeepSeq -import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +--import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST {- ************************************************************************ ===================================== compiler/Language/Haskell/Syntax/UTF8.hs ===================================== @@ -0,0 +1,130 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | +Represents a small chunk of UTF8 text from a source code file. +-} +module Language.Haskell.Syntax.UTF8 + ( + -- * Data-type + TextUTF8() + -- ** Construction + , encodeUTF8 + , unsafeFromShortByteString + -- ** Deconstruction + , bytesUTF8 + , byteStringUTF8 + , decodeUTF8 + , headUTF8 + -- ** Transformation + , linesUTF8 + , unlinesUTF8 + ) where + + +import Prelude + +import Control.DeepSeq +import Data.ByteString (StrictByteString) +import Data.ByteString.Short (ShortByteString(..)) +import qualified Data.ByteString.Short as SBS +import Data.Data +import Data.Foldable (toList) +import Data.String (IsString(..)) +import Data.Word (Word8) + +-- These is a modules are components of the @base@ package, +-- hence they do not directly couple the library to GHC. +import GHC.Base (Char(C#)) +import GHC.Encoding.UTF8 + +{- | +A UTF8 encoded ShortByteString representing the textual snippet of code +associated with a given element of the abstract syntax tree. +-} +newtype TextUTF8 = TextUTF8 { bytesUTF8 :: ShortByteString } + deriving (Data, Eq, Ord) + +instance IsString TextUTF8 where + fromString = encodeUTF8 + +instance NFData TextUTF8 where + rnf (TextUTF8 !sbs) = rnf sbs + +instance Semigroup TextUTF8 where + (TextUTF8 x) <> (TextUTF8 y) = TextUTF8 $ x <> y + +instance Monoid TextUTF8 where + mempty = TextUTF8 mempty + +instance Show TextUTF8 where + show (TextUTF8 sbs) = utf8DecodeShortByteString sbs + +{- | +Convert the UTF8 chunk of text to a 'ByteString'. + +_Time:_ $\mathcal{O}\left( n \right )$ +-} +byteStringUTF8 :: TextUTF8 -> StrictByteString +byteStringUTF8 (TextUTF8 sbs) = SBS.fromShort sbs + +{- | +Decode a UTF8 chunk of text to a 'String'. +-} +{-# INLINE decodeUTF8 #-} +decodeUTF8 :: TextUTF8 -> String +decodeUTF8 = utf8DecodeShortByteString . bytesUTF8 + +{- | +Encode a 'String' as a UTF8 chunk of text. +-} +{-# INLINE encodeUTF8 #-} +encodeUTF8 :: String -> TextUTF8 +encodeUTF8 = TextUTF8 . utf8EncodeShortByteString + +{- | +Extract the first code point from the UTF8 check of text. + +_Time:_ $\mathcal{O}\left( 1 \right )$ +-} +headUTF8 :: TextUTF8 -> Maybe Char +headUTF8 (TextUTF8 sbs@(SBS ba#)) + | SBS.length sbs == 0 = Nothing + | otherwise = + let !(# c#, _ #) = utf8DecodeCharByteArray# ba# 0# + in Just $ C# c# + +{- | +Split a UTF8 fragment of text on newline characters (@'\n'@). +-} +linesUTF8 :: TextUTF8 -> [TextUTF8] +linesUTF8 = fmap TextUTF8 . SBS.split newlineByte . bytesUTF8 + +{- | +Join a collection of UTF8 text fragments with newline characters (@'\n'@). +-} +unlinesUTF8 :: Foldable f => f TextUTF8 -> TextUTF8 +unlinesUTF8 = + TextUTF8 . SBS.intercalate (SBS.singleton newlineByte) . fmap bytesUTF8 . toList + +{- | +Assumes that the shortByteString is already UTF8 encoded. + +/This precondition is not checked!/ +-} +{-# INLINE unsafeFromShortByteString #-} +unsafeFromShortByteString :: ShortByteString -> TextUTF8 +unsafeFromShortByteString = TextUTF8 + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- +-- Internal Functionality +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +newlineByte :: Word8 +newlineByte = 0x0A -- 0x0A (10) is the new line character (\n) + +utf8DecodeShortByteString :: ShortByteString -> [Char] +utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba# + +utf8EncodeShortByteString :: String -> ShortByteString +utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str) ===================================== compiler/ghc.cabal.in ===================================== @@ -1028,6 +1028,7 @@ Library Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Decls.Foreign Language.Haskell.Syntax.Decls.Overlap + Language.Haskell.Syntax.Doc Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension Language.Haskell.Syntax.ImpExp @@ -1037,6 +1038,7 @@ Library Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Specificity Language.Haskell.Syntax.Type + Language.Haskell.Syntax.UTF8 autogen-modules: GHC.Platform.Constants GHC.Settings.Config View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/273fba40c02500253e25b1f32da5488… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/273fba40c02500253e25b1f32da5488… You're receiving this email because of your account on gitlab.haskell.org.

1 0