July 2026 - ghc-commits

[Git][ghc/ghc][wip/dcoutts/issue-26717] 100 commits: gitlab-ci: Drop vestigial references to make build system
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/issue-26717 at Glasgow Haskell Compiler / GHC Commits: 701088db by Ben Gamari at 2026-07-01T10:34:03-04:00 gitlab-ci: Drop vestigial references to make build system - - - - - 62d54a53 by Ben Gamari at 2026-07-01T10:34:03-04:00 gitlab-ci: Add support for running specifying a job's testsuite ways - - - - - 7f97ac2c by Ben Gamari at 2026-07-01T10:34:03-04:00 gitlab-ci: Run llvm testsuite ways in llvm jobs Addresses #25762. - - - - - 7ea75116 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Add normalise_ddump_deriv setup function Some tests check the result of -ddump-deriv, which may contain INLINE pragmas depending on optimization flags. With normalise_ddump_deriv setup function, INLINE pragmas are stripped off. - - - - - c7a8199f by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Use -dsuppress-idinfo to make tests more robust Previously, T18052a and T21755 were failing on 'optasm' and 'optllvm' ways because of visibility of unfoldings. - - - - - a12122e5 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Use a trick to keep large objects alive Previously, T17574 and T19381 were failing on 'optasm' and 'optllvm' ways because of compiler optimizations. Change them to use NOINLINE to prevent unwanted optimizations. - - - - - 1a95b327 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Only run T24224 in 'normal' way This test is a frontend-only one and breaks if optimizations are enabled. - - - - - 8abea737 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Ignore T18118's stderr When optimizations are enabled, the compiler emits a warning (You cannot SPECIALISE ...). The message is not important, so ignore it. - - - - - 9453a722 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Mark T816 and tc216 broken with optimizations These tests are about type checking, so we should not care too much if they are broken with optimizations. See #26952 - - - - - 0aef9ec0 by Ben Gamari at 2026-07-01T10:34:03-04:00 testsuite: ds014 is not longer broken It now appears to pass in the ways it was marked as broken in. Closes #14901. - - - - - 4692d1e4 by Ben Gamari at 2026-07-01T10:34:03-04:00 testsuite: Only run stack cloning tests in the normal way These are too dependent upon code generation specifics to pass in most other ways. - - - - - c154df26 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Update options_ghc_fbyte-code The `-fbyte-code` option used to be overriden by `-fllvm` but it is no longer true since !14872 was merged. I updated the test to accept the new behavior. Closes #27049 - - - - - 5d8bb7b5 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Only run T22744 in 'normal' way This test takes a long time on optimized ways. - - - - - d1e74c8e by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Disable tests that use -finfo-table-map on llvm ways Currently, -finfo-table-map does not work with -fllvm. See #26435 - - - - - 3bf38c84 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Don't run T24726 on optimized ways If optimizations are enabled, the rewrite rule just fires and -drule-check will report nothing. - - - - - e4eef116 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Use -fno-unoptimized-core-for-interpreter when running LinkableUsage01/02 Optimizations for the bytecode interpreter are considered experimental, and need a flag to be enabled. - - - - - 234a9872 by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Suppress unwanted optimizations on T25284 - - - - - 99a2af2f by ARATA Mizuki at 2026-07-01T10:34:03-04:00 testsuite: Don't run stack_big_ret with optimizations Stack layout may change with optimizations enabled. - - - - - 04c836df by ARATA Mizuki at 2026-07-01T10:34:04-04:00 testsuite: Mark memo001 broken on optimized ways See #27396 - - - - - 1a8a24f4 by ARATA Mizuki at 2026-07-01T10:34:04-04:00 testsuite: Mark syn-perf broken on optimized ways See #27398 - - - - - 40412093 by Duncan Coutts at 2026-07-01T10:34:50-04:00 Add a test for thread scheduler fairness It also tests that the interval timer and context switching works. We also test that fairness is lost when the context switching interval is too coarse for the duration of the test. We add this test before doing surgery on the interval timer, so we have decent coverage. - - - - - 3f34d557 by Duncan Coutts at 2026-07-01T10:34:50-04:00 Make exported stop/startTimer no-ops, and rename internal functions Specifically, internally rename: stop/startTimer to pause/unpauseTimer stop/startTicker to pause/unpauseTicker and keep stop/startTimer as exported functions, but now as no-ops. In the past the stop/startTicker actions were used incorrectly as if they were synchronous, which they are not. See issue #27105. We now document pause/unpackTicker as being async and not to be used for the purpose of concurrency safety. The existing stop/startTimer (note Timer not Ticker, the Timer calls the Ticker!) are also exported from the RTS as a public API. This was historically because the ticker used signals and it was important to suspend the timer signel over a process fork. So these functions were exported to be used by the process and unix libraries. We cannot just remove the RTS exports, but we now make them no-ops, and they can be removed from the process and unix library later. This was already documented in a changelog.d entry no-more-timer-signal but due to changes during the MR process the change to make stop/startTicker into no-ops didn't make it into the earlier MR. - - - - - 02e84e5f by Duncan Coutts at 2026-07-01T10:34:51-04:00 Make exitTicker/exitTimer unconditionally synchronous We never use them asynchronously, and we should never need to do so. And update some related comments. - - - - - 13db6a72 by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: update and improve comments on (un)pause and exit Clarify what is async vs sync. - - - - - 43d9a07d by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: split out ppoll/select helper functions Move the #ifdefs out of the main code body by introducing local helper functions and types, which themselves have two implementations (with a common API) based on ppoll or select. This helps improve clarity/readability. - - - - - a5491baa by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: improve the implementation The existing implementation supported pausing and exiting, with the implementation of pausing reling on a mutex and condition variable. It needed to check the pause and stop shared variables on every iteration. It relies on ppoll or select, to wait on the timeout and also wait on an interrupt fd. The interrupt fd was only used for prompt exit/shutdown, and not for pausing or other notification. The pause only needed a lock and a memory operation, but the pause was not prompt. The resume used a lock, and signaling a cond var. The new implementation uses a somewhat more regular design: every notification is done by setting a shared variable and interrupting/notifying the ticker via the fd. The ticker thread does not need to check any shared variables on normal timer expiry, only when it recevies notification. This may be a micro-optimisation, but the tick occurs 100 times a second by default so any improvements in the hot path are amplified. When the ticker thread does receive notification it can check the various shared variables and update its local state. The blocking relies on using ppoll/select but without a timeout. This avoids the condition var and also allows further notifications when paused (also used for unpausing). This design can be extended with further notification types if needed by using and checking further shared vars (or making existing shared vars an enum or counter). This may be used in future for additional notifications to the ticker thread. This will likely be used to proxy wakeUpRts from a single handler context for example. And this approach, avoiding mutexes, is compatible with use from signal handlers. So overall, it's: * slightly simpler / more regular; * easier to extend with additional notifications; * probably slightly more efficient (but a micro-optimisation); * and supports calling notification from signal handlers - - - - - 5b20821e by Duncan Coutts at 2026-07-01T10:34:51-04:00 posix ticker: further minor local renaming for code clarity Improve the clarity with better choice of names for several local vars and function. - - - - - 1f3ec5e0 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: split out local helper functions - - - - - 596e7307 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: provide guarantee about concurrency and idempotency Use a lock to ensure pause/unpause can be used concurrently. Use a paused variable, protected by the lock, to ensure that pause and unpause are both idempotent. This is what the portable API expects. - - - - - 1870edd7 by Duncan Coutts at 2026-07-01T10:34:51-04:00 win32 ticker: make the initial tick be after one wait interval There is no need to tick immediately. This is consistent with the posix implementation. - - - - - 7c15ab5b by Duncan Coutts at 2026-07-01T10:34:51-04:00 ticker: remove now-unnecessary layer of enable/disable There was an atomic variable used to block *part* of the actions of the tick handler. This still did not make stopTimer synchronous, even for the part of the the handle_tick actions it covered. It also added a more expensive (sequentuially consistent) atomic operation in the hot path for the handle_tick action, whereas our new design requires no atomic ops at all. Now that we have eliminate the need for synchronous stop/startTicker, we don't need this not-quite-working-anyway atomic protocol. The new pause/unpauseTicker is explicitly asynchronous and idempotent. - - - - - 8585f8cb by Duncan Coutts at 2026-07-01T10:34:51-04:00 ticker: add TODOs about issue #27250: too much being done from handle_tick The handle_tick should not perform I/O, block, perform long-running operations or call arbitrary user code. Unfortunately, everything to do with the eventlog (at the moment) falls into all those categories. - - - - - 6e381626 by Duncan Coutts at 2026-07-01T22:29:55+01:00 Adjust releaseCapability_ precondition to allow cap->running_task == NULL There are two use cases for releaseCapability_: 1. The current Task (cap->running_task) releases the Capability. The Capability is marked free, and if there is any work to do, an appropriate Task is woken up. 2. There is no current task (cap->task == NULL), and thus the Capability is idle, and we want to wake up an idle Task to animate the Capability. This case uses always_wakeup. Currently, the precondition for releaseCapability_ is cap->running_task != NULL and so the 2nd use cases have to set cap->running_task (which is then immediately overwritten) just to satisfy the precondition. See the use cases in sendMessage and prodCapability. So we can relax the precondition to be: cap->running_task != NULL || always_wakeup so that in the always_wakeup case, we say it is ok for the cap->running_task to be NULL. This lets us simplify sendMessage and prodCapability. In particular it will allow prodCapability to not need a Task parameter. The ulterior motive for all this is that I want to be able to call prodCapability from an OS thread that is not itself a Task, in persuit of issue #27086: disentangle I/O managers from wakeUpRts. The most straightforward way to wake the RTS is using prodCapability, but the context in which we will need to do that are threads that are not Tasks. - - - - - 89404ebc by Duncan Coutts at 2026-07-01T22:29:55+01:00 prodCapability no longer needs to take a Task param Now that releaseCapability_ can accept cap->running_task == NULL then it is no longer necessary for prodCapability to require a Task. - - - - - 4e60c5f6 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Define prodOneCapability There was an existing declaration for this in the header file, but no definition. Similarly, there is a declaration for prodAllCapabilities but no definition, and we don't need it, so remove the declaration. - - - - - 2527026f by Duncan Coutts at 2026-07-01T22:29:56+01:00 Add a wakeUpRtsViaTicker feature to the posix ticker It proxies a call to wakeUpRts, but crucially, this can be called from a signal handler context. It will be used for ctl-c handling. - - - - - aa5a03a5 by Duncan Coutts at 2026-07-01T22:29:56+01:00 Change how wakeUpRts works Previously it would call wakeupIOManager to get a capability to wake up and run. This works but it entangles the I/O managers with unrelated features: ctl-c handling and idle gc (the two features that use wakeUpRts). The reason it used wakeupIOManager is that this action is safe to use from a posix signal handler, since it just posts bytes to a pipe. Otherwise the more direct approach (used e.g. by sendMessage when the target capability is idle) is to use releaseCapability. But that uses condition variables and mutexes, which are not safe to use from within a signal handler. So instead of entangling the (multiple) I/O managers with this, we make wakeUpRts use the direct approach (using prodOneCapability). On win32 the ctl-c console handler can call wakeUpRts directly, since it is called in a proper thread. On posix, to deal with the signal handler problem, we make the signal handler ask the ticker thread to proxy the call to wakeUpRts, since the ticker thread is also a proper thread. This will allow the I/O managers to no longer be concerned with this. This is good because there are many I/O managers (and they're complicated), but there is (on posix) only one ticker implementation. So this is an overall reduction in coupling and complexity. Fixes issue #27086 - - - - - c6d53c16 by sheaf at 2026-07-02T21:35:44-04:00 Test driver: normalise line numbers into libraries When comparing the stdout of tests that print out callstacks, we can't rely on the stability of exact line:column spans pointing into libraries (e.g. ghc-internal), as any change (such as adding a comment) can change them. This commit addresses this by normalising away line:column in callstacks, but only when those point into internal libraries. We don't do this in general, as the exact span might be important to the test (e.g. for a span within the test module itself). Fixes #27387 - - - - - 81ee62e0 by Alan Zimmerman at 2026-07-02T21:36:33-04:00 EPA: Remove LocatedLW from MatchGroup This is the last usage of LocatedLW / SrcSpanAnnLW - - - - - 925959db by Recursion Ninja at 2026-07-04T04:14:12-04:00 Decoupling 'L.H.S' from 'GHC.Hs.Doc' * Migrated 'GHC.Hs.Doc' and 'GHC.Hs.DocString' AST defintions from 'GHC.*' namespace, to new 'Language.Haskell.Syntax.Doc' module in the 'L.H.S' "namespace." * Updated 'HsDocString to be TTG-parameterised as 'HsDocString pass'. * Added 'GHC.Hs.Extension.Pass': splits 'GhcPass'/'Pass' and all 'HsDocString' TTG instances out of 'GHC.Hs.Extension', which re-exports it unchanged (this is backwards compatible and prevents the introduction of a boot file). * Deleted 'GHC.Hs.Doc.hs-boot'; removed all 'L.H.S.*' imports of 'GHC.Hs.Doc'. * Updated 'GHC.Hs.DocString' to be TTG pass-parameterised throughout; moved 'mkHsDocStringChunk'/'unpackHDSC' here (require 'GHC.Utils.Encoding'). * Split 'GHC.Rename.Doc.rnHsDoc' from 'rnHsDocIdentifiersOnly'. * Updated parser, renamer, typechecker, HIE, and exact-print for new types. * Added 'HsDocString' TTG instances for 'DocNameI' to 'Haddock.Types'. * Killed the last module loop between GHC.* and LHS.*. - Only edges from LHS.* to GHC.Data.FastString now! Resolves #26971 - - - - - b7e24044 by mangoiv at 2026-07-04T04:14:56-04:00 ci: retry fetching test metrics Retry fetching test metrics to make the CI not fail if the services is temporarily unavailable - - - - - 4180af3f by Zubin Duggal at 2026-07-04T04:15:38-04:00 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin - - - - - 242d4317 by sheaf at 2026-07-04T04:16:19-04:00 Remove outdated comment in GHC.Data.ShortText There was a long comment in GHC.Data.ShortText about a workaround that was necessary when bootstrapping with GHC 9.2 and below. The actual logic has since been dropped, but the comment remained. This commit removes the vestigial comment. - - - - - 9b714c4c by Zubin Duggal at 2026-07-05T09:40:36+05:30 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 - - - - - 4a59b3ee by Zubin Duggal at 2026-07-05T09:40:36+05:30 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf - - - - - 383ddcd4 by Alan Zimmerman at 2026-07-06T07:08:16-04:00 EPA: Move the 'where' annotation for PatSynBind This allows us to move it out of the MatchGroup exact print annotation too - - - - - 66d1a5d5 by fendor at 2026-07-07T16:57:56-04:00 Add 'backendInfoTableMapValidity' backend predicate Check whether the backend supports the `-finfo-table-map` flag and ignore it otherwise. Improve by-design documentation of `backendCodeOutput`. `Backend` is **abstract by design**. Make this clearer in `backendCodeOutput` which is incorrectly being used as a proxy for `Backend`. Instead, define the desired property predicates in GHC.Driver.Backend In the process, make `backendCodeOutput` total. - - - - - 74f1071d by fendor at 2026-07-07T16:57:56-04:00 Add failing test for `-finfo-table-map` and bytecode backend If you compile a module using the bytecode backend, with -finfo-table-map, then the info table map doesn't get populated for the module. This is because the -finfo-table-map code path is implemented mostly in the StgToCmm phase which isn't run when creating bytecode. Ticket #27039 - - - - - 28d63bca by mangoiv at 2026-07-07T16:59:16-04:00 ci: don't fail nightly if there have been no changes that night Fixes #27127 - - - - - 4ebfc478 by Rodrigo Mesquita at 2026-07-08T04:47:53-04:00 ttg: Using ShortText over FastString in the AST To make the AST independent of GHC, this commit replaces usages of `FastString` with `HText` in the AST, killing the last edge from Language.Haskell.* to GHC.* modules. Even though we /do/ want to use FastStrings in general -- critically in Names or Ids -- there is no particular reason for the FastStrings that occur in the AST proper to be FastStrings. Strings in the AST are typically unique and don't benefit particularly from being interned FastStrings with Uniques for fast comparison. `HText` is a type synonym for `ShortText` which uses GHC's Modified UTF-8 encoding exclusively. Modified UTF-8 must be used to represent the Haskell AST because the Haskell Report allows surrogate code points. `Data.Text.Text` functions use Standard UTF-8 which replace surrogates with a placeholder value, thus `Data.Text.Text` is unsuitable for AST strings. See the `Language.Haskell.Syntax.Text` module header for more details. Final progress towards #21592 Closes #21628 - - - - - d910b353 by Simon Peyton Jones at 2026-07-08T04:48:36-04:00 Update equality-type documenation in GHC.Builtin.Types.Prim Fix #27466 - - - - - b2530542 by Simon Peyton Jones at 2026-07-08T04:48:36-04:00 Honour -dsuppress-coercions in GHC.Core.TyCo.pprCo Fixes #27467 - - - - - 9a73179a by Facundo Domínguez at 2026-07-08T04:49:26-04:00 Add item to MR checklist asking to squash fixup commits after approval The checklist has an item that reads All commits are either individually buildable or squashed. This item could be checked immediately after sending the merge request though. If reviewers ask for amends later on, and the author amends the merge request, there was no item that would remind the contributors to squash the fixup commits before landing. This commit adds a new item After all approvals and before landing: all fixup commits are squashed with their originating commits. which should be harder to mark as done before approvals have been given. - - - - - ed09895d by Andreas Klebinger at 2026-07-08T16:53:27-04:00 Fix a profiling race condition resulting in segfaults. StgToCmm: Don't assume tagged FUN closures in closureCodeBody. When entering a closure the self/node pointer might not be tagged in some situations when a thunk is evaluated by multiple threads. So we most AND away the tag bits rather than subtracting an expected tag. Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC. In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens another thread or the GC itself might mutate the closure making entering it no longer valid. We now check for this. Add test and changelog for #27123 fixes. - - - - - 67c03eb2 by Cheng Shao at 2026-07-08T16:54:09-04:00 ghc-heap: fix invalid srtlen returned by peekItbl when no-TNTC This patch fixes the no-TNTC code path of `peekItbl` so that it looks at the right memory address when reading the `srt` field from the `StgInfoTable_` struct. Also adds a `T27465` regression test that reproduces the bug on no-TNTC builds before the fix. Fixes #27465. Co-authored-by: Codex <codex(a)openai.com> - - - - - 2ecabb4f by Zubin Duggal at 2026-07-09T09:23:25-04:00 hadrian: binary-dist-dir should not be the default target Revert behaviour to pre 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2 In 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2, we applied the following behaviour change: ``` hadrian: Build stage 2 cross compilers ... * hadrian: Make binary-dist-dir the default build target. This allows us to have the logic in one place about which libraries/stages to build with cross compilers. Fixes #24192 ``` This is a major regression to development experience, a plain hadrian/build --freeze1 now takes ages because we rebuild all docs (which need to go in the binary dist dir). `binary-dist-dir` is the wrong default target for regular GHC development work Fixes #27445 - - - - - e16388e3 by Zubin Duggal at 2026-07-09T09:23:25-04:00 .gitignore: Add the hadrian system.config introduced by commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2 Since commit 23c9b6c392f52ec9d7a8618b204ff6b885f5fba2 Author: Matthew Pickering <matthewtpickering(a)gmail.com> Date: Thu Dec 21 16:17:41 2023 +0000 hadrian: Build stage 2 cross compilers ./configure produces /hadrian/cfg/system.config.{host,target} Add these to .gitignore - - - - - 7e8abf41 by Alan Zimmerman at 2026-07-09T09:24:12-04:00 EPA: Replace AnnListItem with simply [TrailingAnn] Remove the unnecessary wrapper around a single field. - - - - - 29032f17 by Zubin Duggal at 2026-07-09T09:24:58-04:00 testsuite: Keep real reason for fragile test failures - - - - - c34e03a7 by Zubin Duggal at 2026-07-09T09:24:58-04:00 testsuite: Fall back to the failure reason for empty JUnit bodies - - - - - 409d40f0 by Zubin Duggal at 2026-07-09T09:24:58-04:00 testsuite: Show output diffs in JUnit output Also refactor compare_outputs to return essentially a `Maybe Diff` (`CompareOutput`) instead of a bool, but more pythonic. This allows us to pass the diff through nice. - - - - - 06fee1ab by Zubin Duggal at 2026-07-09T09:24:58-04:00 perf notes: include stat deviation and acceptance window in notes so they show up in gitlab - - - - - 57c0f32c by mangoiv at 2026-07-10T11:08:38-04:00 driver: enable -finter-module-far-jumps by default this fixes a compatibility bug with certain binutils/gcc versions where we were seeing jump offset overflow errors. This commit can probably reverted if we stop supporting the problematic binutils/gcc verions (2.44 and 14.2, respectively) Reolves #26994 - - - - - 4396a6f2 by Andrea Vezzosi at 2026-07-10T11:09:25-04:00 [Fix #27287] preserve ModBreaks in ModIface - - - - - ed261a7e by Cheng Shao at 2026-07-14T17:59:38-04:00 hadrian: fix HLS support This patch fixes hadrian's HLS support so one can rely on HLS when working on the hadrian codebase. Fixes #27480. Not building/linking shared libraries for hadrian is a severely premature optimization; this top-level setting in `cabal.project` only affects home packages while the dependencies in the cabal store are built with vanilla/dynamic anyway, and even adding dynamic builds to home packages would not be costly due to cabal's usage of `-dynamic-too`. - - - - - eee8ec5b by Cheng Shao at 2026-07-14T18:00:20-04:00 compiler: fix miscompiled %load_relaxed, add missing %store_relaxed This patch fixes the %load_relaxed cmm primop compilation logic to correctly use relaxed memory ordering, and adds the missing %store_relaxed primop. Parsing logic of %load/%store with explicit ordering is covered in the AtomicFetch test case. Fixes #27483. Co-authored-by: Codex <codex(a)openai.com> - - - - - 1718230f by Alan Zimmerman at 2026-07-14T18:01:06-04:00 EPA: Keep binds and sigs together in HsValBindsLR We combine them into a single list for GhcPs, wrapped in the ValBind data type, which is the bind equivalent of ValD, having constructors for binds and sigs. This simplifies exact print processing, especially when using it to update the contents of local binds, as we no longer need AnnSortKey BindTag - - - - - 6bd1ad2a by Andreas Klebinger at 2026-07-14T18:01:49-04:00 Bump nofib submodule to account for MonoLocalBinds. New versions of GHC enable MonoLocalBinds by default. This breaks some of the benchmarks. I've fixed this and this bump pulls in that fix. - - - - - 7eb0f1c9 by Cheng Shao at 2026-07-14T18:02:31-04:00 testsuite: fix bytecodeIPE test under +ipe flavours This patch fixes the bytecodeIPE test under +ipe flavours. It used to fail under +ipe because the RTS is built with IPE info, then stg_AP_info in RTS carries IPE info, so whereFrom wouldn't return Nothing. Now the test checks IPE info of a datacon in the ghci-loaded module which is not affected by whether the RTS is built with IPE info or not. Fixes #27498. Co-authored-by: Codex <codex(a)openai.com> - - - - - ef038aae by cydparser at 2026-07-15T04:35:41-04:00 Reduce bytes allocated for `capabilities` in RTS (fixes #27487) In rts/Capability.c, `capabilities` is an array of pointers, but it was allocated as if it were an array of Capability's. - - - - - d377e83e by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_readTVarIOzh This patch fixes missing UNTAG on the current value closure read from StgTVar. UNTAG is a no-op when it's stg_TREC_HEADER_info which is word aligned; it may be a tagged closure, and reading info table from the tagged address is an unaligned load which may cause issues on platforms with strict alignment requirements. Co-authored-by: Codex <codex(a)openai.com> - - - - - 8ed03842 by Cheng Shao at 2026-07-15T04:36:27-04:00 rts: fix missing UNTAG in stg_control0zh_ll This patch fixes missing UNTAG on the cont closure returned by captureContinuationAndAbort. In case it's not NULL, captureContinuationAndAbort returns a tagged StgContinuation closure, in which case it must be untagged before accessing the apply_mask_frame field. In the past it worked out of luck: when apply_mask_frame was NULL then mask_frame_offset is also 0 so the control flow didn't diverge to a wrong path. Still, this is horribly wrong and will crash once StgContinuation struct is refactored and fields are shuffled around. Co-authored-by: Codex <codex(a)openai.com> - - - - - 5aa7000a by Cheng Shao at 2026-07-15T04:37:08-04:00 compiler: fix redundant AP thunk codegen when not using -ticky-ap-thunk This patch fixes a double negation confusion in !7525 that results in some redundant AP thunk code generation when not using -ticky-ap-thunk. Now, we use `stgToCmmUseStdApThunk` to indicate whether precomputed AP thunks in the RTS should be used, which defaults to `True`, unless `-ticky-ap-thunk` is passed. `-finfo-table-map` now also implies `-ticky-ap-thunk`, since when doing IPE profiling we want the generated AP thunks to be unique. Fixes #27502. ------------------------- Metric Decrease: T3064 ------------------------- Co-authored-by: Codex <codex(a)openai.com> - - - - - d43a7b7a by Brian McKenna at 2026-07-15T20:10:04+02:00 Strip ticks when desugaring bool guards The special `considerAccessible` pattern was broken when compiling with debug info. Compiling with debug info wraps expressions with `SourceNote` ticks, which broke the internals of the `desugarBoolGuard` function. Ticks are now ignored within this function. Fixes #27360 - - - - - ede4b17b by Ben Gamari at 2026-07-15T22:59:53-04:00 base: Display ExceptionContext in WhileHandling's textual description As originally-implemented the implementation for `WhileHandling(displayExceptionAnnotation)` would display the `ExceptionContext` of the exception which it carries (as this was the behavior of `displayException`, in terms of which `displayExceptionAnnotation` was implemented). However, in 284ffab3 the definition of `SomeException(displayException)` was changed to exclude the `ExceptionContext`. This means that `WhileHandling(displayExceptionAnnotation)` fails to describe the provenance of the exception which it captures, greatly limiting its utility. Return the implementation to its originally-specified behavior by implementing `WhileHandling(displayExceptionAnnotation)` in terms of `displayExceptionWithInfo`. Fixes #27456. - - - - - 0f64f348 by Cheng Shao at 2026-07-16T15:41:08+00:00 ci: add missing docker permission workaround in abi-test job - - - - - 660cb239 by Cheng Shao at 2026-07-16T19:37:48+00:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 08130257 by Cheng Shao at 2026-07-16T19:37:48+00:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00 Mark various language extension flags as deprecated (see #27329) The following language extensions are now deprecated: - AlternativeLayoutRule - AlternativeLayoutRuleTransitional - ParallelArrays - PolymorphicComponents - Rank2Types In addition, the warning `-Walternative-layout-rule-transitional` has been marked as deprecated, as it is emitted only under the deprecated extension `XAlternativeLayoutRuleTransitional`. - - - - - fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00 base: re-export GHC.Environment.getFullArgs from System.Environment CLC proposal https://github.com/haskell/core-libraries-committee/issues/431 - - - - - de766bb8 by Duncan Coutts at 2026-07-17T11:44:44+01:00 Fix failing test GcStaticPointers for non-moving GC Minor mistake in asserting something before checking for that same thing. Specifically, Bdescr asserts HEAP_ALLOCED_GC, but Bdescr was being used prior to a guard that checks HEAP_ALLOCED_GC. The solution is just to move the use of Bdescr after the guard. Fixes issue #27284 Thanks to Simon Jakobi for identifying the problem. - - - - - b382e938 by Duncan Coutts at 2026-07-17T11:56:09+01:00 Eliminate STM_AWOKEN It was used as nullary closure for the block_info.closure in the case of a thread being awoken after an STM transaction. However, while it was written, it was never read, so contributed nothing to the behaviour. Furthermore, in the only place it was set (in tryWakeupThread) the why_blocked was immediately overwritten by the NotBlocked status, and the block_info was updated accordingly (by appendToRunQueue). So it didn't even serve a purpose of clarifying an intermediate state, there really was no such intermediate state. Cleaning this up will allow the BlockedOnSTM case to follow the same pattern as the other why_blocked cases that do not use the block_info, and in turn this reduces the number of different categories. - - - - - 94fd9797 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Document that eventlog thread stop code ThreadBlocked is no longer used It has not been used since GHC 7.0.x (2011). In 7.2 all the BlockedOn* codes were added, and these were and are used instead of ThreadBlocked. - - - - - 5417604b by Duncan Coutts at 2026-07-17T11:56:10+01:00 Add a proper mapping to eventlog external thread stop status That is the mapping from rts-internal codes, to the coes used in the status field in the eventlog EVENT_STOP_THREAD event. See issue #9003 for what goes wrong when we mess this up. In that ticket, people note that we should really not require the internal tso->why_blocked codes to leak into the external eventlog thread stop codes. The same principle applies to the StgThreadReturnCode. This change properly separates them, and explicitly maps between them using a pair of (compact, constant) tables. These tables are pretty small (with no alignment constraints) and will soon shrink so it seems a sensible tradeoff. We also introduce and use proper EVENT_STOP_THREAD constants in the event log format header. Previously there was not specification in the code for these (only in the docs): the values were encoded into the conversion code. This will allow us to renumber the internal why_blockd codes without breaking the eventlog output. - - - - - 9833f370 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Remove unused tso->block_info.wakeup member. Presumably it was used once, but not now. - - - - - eb25b5de by Duncan Coutts at 2026-07-17T11:56:10+01:00 Document StgTSOBlockInfo to say what cases use what members In principle, tso->why_blocked is the tag for the StgTSOBlockInfo union, so we should be able to say for each union member the why_blocked cases that use that member. - - - - - 3ed4f009 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Add a tso->block_info.mvar member and use it in preference to the generic block_info.closure union member, with casts. The plan is that when we know what case we're in (via tso->why_blocked) then we can always access the correct union member, and so we will only need to access block_info.closure for generic cases where we don't know or don't care. - - - - - 44dc01bc by Duncan Coutts at 2026-07-17T11:56:10+01:00 Add a tso->block_info.unused member and use it in preference to the generic block_info.closure union member, with casts. The plan is that when we know what case we're in (via tso->why_blocked) then we can always access the correct union member, and so we will only need to access block_info.closure for generic cases where we don't know or don't care. - - - - - b327f4f8 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Avoid storing to tso->block_info.closure In one case we can use a specific union member (.prev) instead. In several cases the stores were in fact redundant because of subsequent overwrites. In scavengeTSO we replace setting tso->block_info.closure to a valid closure, with an assertion that the block_info.unused is already set to END_TSO_QUEUE which is a valid (static) closure. - - - - - cf67327c by Duncan Coutts at 2026-07-17T11:56:10+01:00 Renumber the tso->why_blocked constants We can do this now because we have separated the internal values from the external ones used in the eventlog. This lets us put them back into a deliberate order and consolodate some gaps. More importantly, it is a prepation for a slightly more sophisticated encoding. - - - - - 3fd014fa by Duncan Coutts at 2026-07-17T11:56:10+01:00 Define constants for the existing stg_threadStatuszh return codes The stg_threadStatuszh reuses the internal tso->why_blocked codes but also extends them with a couple previously magic values. This is awkward since we need to know what those magic values are so we don't accidentally use those values to mean something else. By pulling a definition up to where the why_blocked codes are defined we will be able to avoid mistakenly assining those codes some meaning (or just changing the BlockedThreadComplete, BlockedThreadKilled code if necessary). - - - - - 6d06acce by Duncan Coutts at 2026-07-17T11:56:10+01:00 Extend the tso->why_blocked encoding to indicate block_info closures We use some bit tricks to cheaply and generically test if a tso->why_blocked tag implies that the corresponding tso->block_info will contain a non-trivial valid closure (i.e. not just block_info.unused set to END_TSO_QUEUE). In particular we arrange for most why_blocked values to naturally have a distinguishing bit, but for the BlockedOn{Read,Write,Delay} cases, they can come in either non-closure or closure forms. We allow an additional bit to distinguish these cases. The non-closure forms are only from legacy I/O managers: select and win32-legacy. So this extra bit mechanism will be able to be retired once the legacy I/O managers are themselves retired. This means in a few places we need to untag the why_blocked value before inspecting it, but in most places we do not. - - - - - 98990a16 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Use BlockInfoForceNonClosure in the select I/O manager - - - - - ef3b387a by Duncan Coutts at 2026-07-17T11:56:10+01:00 Use BlockInfoForceNonClosure in the win32-legacy I/O manager for the BlockedOn{Read,Write} since these use the non-heap allocated StgAsyncIOResult. - - - - - 4b31d021 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Enforce the why_blocked and block_info rules in checkTSO We now check the cases wher IsBlockInfoClosure should hold, the cases that are supposed to use block_info.unused == END_TSO_QUEUE, and which cases are allowed to use BlockInfoForceNonClosure. This partially enforces the use of why_blocked as a tag for the block_info union. We could be stricter and check for the correct expected info table for the closure cases. - - - - - cbda8529 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Use IsBlockInfoClosure to simplify several tests In GC and generic traversal we need to know if we should look at the block_info.closure or not. Now we can do just that using a cheap bit test on the why_blocked tag. This fixes issue 26717, where the problem was that some GC modes did not know when to look at block_info.closure, because the poll I/O manager uses a closure for BlockedOn{Read,Write} while the select I/O manager uses a non-closure. Now this information is in the why_blocked tag itself. - - - - - 39b64d45 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Remove the now-unused scavengeTSOIOManager The GC no longer has to delegate to the I/O manager, since it can use IsBlockInfoClosure to decide things itself. - - - - - 2935177a by Duncan Coutts at 2026-07-17T11:56:10+01:00 Remove duplicate assertion - - - - - 33f011e2 by Duncan Coutts at 2026-07-17T11:56:10+01:00 Follow atomic access rules more consistently for tso->why_blocked The rule is this: store block_info *before* why_blocked store why_blocked using store release load why_blocked using load acquire load block_info *after* why_blocked This is a an atomic store release / load acquire pair and (if the reads are in a separate thread to the writes, and the read receives the value stored) then this guarantees a full "happens before" relationship of these stores and loads. In some cases, we do not need a full load acquire, because we don't read the block_info at all and so do not need any ordering. In this case we just need an atomic relaxed load. This was being followed in most places, but not all. If there's good reason in any case that we don't need atomic access, then we should document that in a comment. In the absence of that I think it's easier to follow the rule everywhere. - - - - - 2476509e by Duncan Coutts at 2026-07-17T11:56:10+01:00 Add a changelog entry - - - - - 393 changed files: - .gitignore - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/merge_request_templates/Default.md - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - .gitlab/test-metrics.sh - + changelog.d/T21628 - + changelog.d/T26716 - + changelog.d/T27123.md - + changelog.d/T27329 - + changelog.d/T27360 - + changelog.d/T27456 - + changelog.d/fix-absent-dict-projection - + changelog.d/fix-cmm-atomic-load-store - + changelog.d/fix-make-install-j - + changelog.d/fix-peekitbl-no-tntc - + changelog.d/fix-use-std-ap-thunk - + changelog.d/inter-module-far-jumps-aarch64-default - changelog.d/semaphore-v2 - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/Builtin/Utils.hs - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/CLabel.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/TyCo/Ppr.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCon.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Data/FastString.hs - compiler/GHC/Data/StringBuffer.hs - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Config/StgToCmm.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Doc.hs - − compiler/GHC/Hs/Doc.hs-boot - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Extension.hs - + compiler/GHC/Hs/Extension/Pass.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Lit.hs - compiler/GHC/Hs/Type.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Breakpoints.hs - + compiler/GHC/HsToCore/Breakpoints/Types.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Foreign/Wasm.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Platform/Ways.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Rename/Doc.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Rename/Module.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/StgToCmm/Config.hs - compiler/GHC/StgToCmm/Foreign.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/FFI.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Rank.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/FieldLabel.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/Literal.hs - compiler/GHC/Unit/Module/ModGuts.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Unit/Module/Warnings.hs - compiler/GHC/Unit/Module/WholeCoreBindings.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Binds.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Decls/Foreign.hs - + compiler/Language/Haskell/Syntax/Doc.hs - compiler/Language/Haskell/Syntax/Expr.hs - compiler/Language/Haskell/Syntax/Expr.hs-boot - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/Language/Haskell/Syntax/Lit.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - + compiler/Language/Haskell/Syntax/Text.hs - compiler/Language/Haskell/Syntax/Type.hs - − compiler/Language/Haskell/Syntax/Type.hs-boot - compiler/ghc.cabal.in - docs/users_guide/eventlog-formats.rst - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/static_pointers.rst - docs/users_guide/using-optimisation.rst - ghc/GHCi/UI.hs - hadrian/bindist/Makefile - hadrian/cabal.project - hadrian/src/Rules.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Settings/Warnings.hs - libraries/base/changelog.md - libraries/base/src/System/Environment.hs - libraries/base/tests/T15349.stderr - libraries/base/tests/all.T - libraries/ghc-boot/GHC/Data/ShortText.hs - + libraries/ghc-heap/tests/T27465.hs - + libraries/ghc-heap/tests/T27465.stdout - libraries/ghc-heap/tests/all.T - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Conc/Sync.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc - libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc - libraries/ghc-internal/tests/backtraces/T14532b.stdout - libraries/semaphore-compat - nofib - rts/Apply.cmm - rts/Capability.c - rts/Capability.h - rts/ContinuationOps.cmm - rts/IOManager.c - rts/IOManager.h - rts/Messages.c - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/RaiseAsync.h - rts/RtsStartup.c - rts/STM.c - rts/Schedule.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Ticker.h - rts/Timer.c - rts/Timer.h - rts/Trace.c - rts/Trace.h - rts/TraverseHeap.c - rts/include/Cmm.h - rts/include/rts/Constants.h - rts/include/rts/EventLogFormat.h - rts/include/rts/Timer.h - rts/include/rts/storage/TSO.h - rts/include/stg/MiscClosures.h - rts/posix/Poll.c - rts/posix/Select.c - rts/posix/Ticker.c - rts/posix/Timeout.c - rts/sm/Compact.c - rts/sm/GC.c - rts/sm/NonMovingMark.c - rts/sm/Sanity.c - rts/sm/Scav.c - rts/win32/AsyncMIO.c - rts/win32/Ticker.c - testsuite/driver/junit.py - testsuite/driver/perf_notes.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/driver/testutil.py - testsuite/tests/arityanal/should_compile/T21755.stderr - testsuite/tests/arityanal/should_compile/all.T - testsuite/tests/backpack/should_compile/T13149.bkp - testsuite/tests/bytecode/TLinkable/all.T - testsuite/tests/cmm/should_compile/all.T - testsuite/tests/cmm/should_run/AtomicFetch.hs - testsuite/tests/cmm/should_run/AtomicFetch_cmm.cmm - testsuite/tests/codeGen/should_compile/T25177.stderr - testsuite/tests/codeGen/should_run/cgrun025.stderr - + testsuite/tests/concurrent/should_run/T27105.hs - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/core-to-stg/T25284/Cls.hs - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/deSugar/should_fail/all.T - testsuite/tests/deSugar/should_run/all.T - testsuite/tests/deriving/should_compile/all.T - testsuite/tests/determinism/determ017/A.hs - testsuite/tests/dmdanal/should_compile/T18982.stderr - testsuite/tests/driver/options_ghc/Mod_fbyte_code.hs - testsuite/tests/driver/options_ghc/all.T - testsuite/tests/driver/options_ghc/options_ghc_fbyte-code.stderr - testsuite/tests/exceptions/T26759.stderr - testsuite/tests/generics/GenDerivOutput.hs - testsuite/tests/generics/GenDerivOutput1_0.hs - testsuite/tests/generics/GenDerivOutput1_1.hs - testsuite/tests/generics/T10604/T10604_deriving.hs - testsuite/tests/generics/T10604/all.T - testsuite/tests/generics/all.T - testsuite/tests/ghc-api/T25121_status.stdout - testsuite/tests/ghc-api/annotations-literals/parsed.hs - testsuite/tests/ghc-api/exactprint/T22919.stderr - testsuite/tests/ghc-api/exactprint/Test20239.stderr - testsuite/tests/ghc-api/exactprint/ZeroWidthSemi.stderr - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghci/scripts/T12005.script - testsuite/tests/ghci/scripts/all.T - + testsuite/tests/ghci/scripts/bytecodeIPE.hs - + testsuite/tests/ghci/scripts/bytecodeIPE.script - + testsuite/tests/ghci/scripts/bytecodeIPE.stdout - testsuite/tests/ghci/should_run/Makefile - + testsuite/tests/ghci/should_run/T27287.hs - + testsuite/tests/ghci/should_run/T27287.stdout - testsuite/tests/ghci/should_run/all.T - testsuite/tests/haddock/perf/Fold.hs - testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr - testsuite/tests/haddock/should_compile_flag_haddock/T24221.stderr - testsuite/tests/indexed-types/should_fail/T7354.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/layout/layout001.stdout - testsuite/tests/layout/layout002.stdout - testsuite/tests/layout/layout003.stdout - testsuite/tests/layout/layout004.stdout - testsuite/tests/layout/layout005.stdout - testsuite/tests/layout/layout006.stdout - testsuite/tests/layout/layout007.stdout - testsuite/tests/layout/layout008.stdout - testsuite/tests/layout/layout009.stdout - testsuite/tests/linear/should_compile/T1735Min.hs - testsuite/tests/mdo/should_fail/mdofail006.stderr - testsuite/tests/module/mod185.stderr - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - + testsuite/tests/parser/should_compile/T13087.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/parser/should_compile/T15279.stderr - testsuite/tests/parser/should_compile/T15323.stderr - testsuite/tests/parser/should_compile/T20452.stderr - testsuite/tests/parser/should_compile/T20718.stderr - testsuite/tests/parser/should_compile/T20718b.stderr - testsuite/tests/parser/should_compile/T20846.stderr - testsuite/tests/parser/should_compile/T23315/T23315.stderr - testsuite/tests/parser/should_compile/all.T - testsuite/tests/parser/should_fail/T8431.stderr - testsuite/tests/parser/should_fail/readFail038.stderr - + testsuite/tests/parser/should_run/StringStartsWithNull.hs - + testsuite/tests/parser/should_run/StringStartsWithNull.stdout - testsuite/tests/parser/should_run/all.T - testsuite/tests/perf/compiler/T3064.hs - testsuite/tests/perf/compiler/all.T - testsuite/tests/perf/compiler/hard_hole_fits.stderr - + testsuite/tests/pmcheck/should_compile/T27360.hs - testsuite/tests/pmcheck/should_compile/all.T - testsuite/tests/polykinds/T7594.hs - testsuite/tests/printer/AnnotationNoListTuplePuns.stdout - testsuite/tests/printer/T18052a.stderr - testsuite/tests/printer/T18791.stderr - testsuite/tests/printer/Test20297.stdout - testsuite/tests/printer/Test24533.stdout - testsuite/tests/printer/all.T - testsuite/tests/profiling/perf/T23103/all.T - testsuite/tests/profiling/should_run/all.T - testsuite/tests/programs/thurston-modular-arith/Main.hs - testsuite/tests/rts/T17574.hs - testsuite/tests/rts/T19381.hs - + testsuite/tests/rts/T27123.hs - testsuite/tests/rts/all.T - testsuite/tests/rts/ipe/IpeStats/Fold.hs - testsuite/tests/rts/ipe/T24005/all.T - testsuite/tests/runghc/T7859.stderr-mingw32 - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/simplCore/should_compile/DataToTagFamilyScrut.stderr - testsuite/tests/simplCore/should_compile/T11562.hs - testsuite/tests/simplCore/should_compile/T14978.stdout - testsuite/tests/simplCore/should_compile/T18013.stderr - testsuite/tests/simplCore/should_compile/T24229a.stderr - testsuite/tests/simplCore/should_compile/T24229b.stderr - testsuite/tests/simplCore/should_compile/T26615.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs - testsuite/tests/typecheck/should_compile/T12507.hs - testsuite/tests/typecheck/should_compile/T13951.hs - testsuite/tests/typecheck/should_compile/T15242.stderr - testsuite/tests/typecheck/should_compile/T18920.hs - testsuite/tests/typecheck/should_compile/T2595.hs - testsuite/tests/typecheck/should_compile/T7541.hs - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7368a.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731-short.hs - testsuite/tests/typecheck/should_run/T3731.hs - testsuite/tests/typecheck/should_run/church.hs - testsuite/tests/typecheck/should_run/tcrun008.hs - testsuite/tests/typecheck/should_run/tcrun017.hs - testsuite/tests/typecheck/should_run/tcrun026.hs - testsuite/tests/typecheck/should_run/tcrun035.hs - testsuite/tests/typecheck/should_run/tcrun036.hs - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/check-exact/check-exact.cabal - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.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/Interface/Create.hs - utils/haddock/haddock-api/src/Haddock/Interface/LexParseRn.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613756e49fc0049397f3c362080fd0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/613756e49fc0049397f3c362080fd0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/external-unit-db-cache] Split State.hs into many more modules
by Hannes Siebenhandl (＠fendor) 17 Jul '26

17 Jul '26

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: ba143db3 by fendor at 2026-07-17T12:47:29+02:00 Split State.hs into many more modules - - - - - 23 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/External/Database.hs - + compiler/GHC/Unit/External/Index.hs - + compiler/GHC/Unit/External/ModuleOrigin.hs - + compiler/GHC/Unit/External/Providers.hs - + compiler/GHC/Unit/External/Query.hs - + compiler/GHC/Unit/External/Substitution.hs - + compiler/GHC/Unit/External/Validate.hs - + compiler/GHC/Unit/External/Visibility.hs - + compiler/GHC/Unit/External/Wired.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Unit/State.hs-boot - compiler/GHC/Unit/Types.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - hadrian/src/Rules/Generate.hs - testsuite/tests/count-deps/CountDepsParser.stdout - utils/haddock/haddock-api/src/Haddock.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do logger <- getLogger hsc_env <- getSession - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -779,7 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env , ue_eud = ue_eud old_unit_env - , ue_unit_index = ue_unit_index old_unit_env + , ue_uic = ue_uic old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -838,7 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , ue_eps = ue_eps unit_env0 , ue_module_graph = ue_module_graph unit_env0 , ue_eud = ue_eud unit_env0 - , ue_unit_index = ue_unit_index unit_env0 + , ue_uic = ue_uic unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -886,7 +886,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph unit_env) - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -451,7 +451,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env) -- update platform constants @@ -469,7 +469,7 @@ addUnit u = do , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_eud = ue_eud old_unit_env - , ue_unit_index = ue_unit_index old_unit_env + , ue_uic = ue_uic old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Driver.Env , hsc_HUG , hsc_all_home_unit_ids , hscUnitIndex - , hsc_unit_index + , hscUIC , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -94,6 +94,7 @@ import GHC.Builtin.Names import Data.IORef import qualified Data.Set as Set import GHC.Unit.External.Database (ExternalUnitDatabaseCache, readExternalUnitDatabases, ExternalUnitDatabases) +import GHC.Unit.External.Index runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env hsc = do @@ -233,10 +234,10 @@ hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env) hscUnitIndex :: HscEnv -> IO UnitIndex -hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env) +hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env) -hsc_unit_index :: HscEnv -> IORef UnitIndex -hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env) +hscUIC :: HscEnv -> UnitIndexCache +hscUIC hsc_env = ue_uic (hsc_unit_env hsc_env) -------------------------------------------------------------------------------- -- * Queries on Transitive Closure ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do let hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -40,6 +40,8 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv , ueEPS -- Not really needed, get directly type families and rule base! + , ueEUD + , ueUI , updateHug -- * Unit Env helper functions , ue_currentHomeUnitEnv @@ -110,6 +112,7 @@ import qualified Data.Set as Set import GHC.Unit.External import GHC.Unit.External.Database +import GHC.Unit.External.Index import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types @@ -131,7 +134,6 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -177,19 +179,28 @@ data UnitEnv = UnitEnv -- ^ GHC name/version (used for dynamic library suffix) , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) - -- TODO: @fendor Docs - , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) - -- TODO: @fendor Docs + -- ^ Global cache of already read package databases + + , ue_uic :: {-# UNPACK #-} !UnitIndexCache + -- ^ Index of already processed 'UnitInfo's. + -- Shares state over all 'UnitState' in the 'HomeUnitGraph'. } ueEPS :: UnitEnv -> IO ExternalPackageState ueEPS = eucEPS . ue_eps +ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId) +ueEUD = readExternalUnitDatabases . ue_eud + +ueUI :: UnitEnv -> IO UnitIndex +ueUI = readUnitIndex . ue_uic + + initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache eud <- initExternalUnitDatabaseCache - unit_index <- newIORef (initUnitIndex) + uic <- initUnitIndexCache return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -198,7 +209,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud - , ue_unit_index = unit_index + , ue_uic = uic } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -1,31 +1,64 @@ module GHC.Unit.External.Database ( - -- * + -- * Mutable cache for 'ExternalUnitDatabases' ExternalUnitDatabaseCache (..), initExternalUnitDatabaseCache, readExternalUnitDatabases, readExternalUnitDatabase, cacheExternalUnitDatabase, clearExternalUnitDatabaseCache, - -- * + -- * 'ExternalUnitDatabases' ExternalUnitDatabases, emptyExternalUnitDatabases, insertExternalUnitDatabases, deleteExternalUnitDatabases, lookupExternalUnitDatabases, - -- * + -- * 'UnitDatabase' UnitDatabase (..), + mergeDatabases, + UnitPrecedenceMap, + sortByPreference, + compareByPreference, + -- * Reading packages from disk. + UnitDbConfig(..), + readOrGetUnitDatabase, + readUnitDatabases, + readUnitDatabase, + getUnitDbRefs, + resolveUnitDatabase, ) where import GHC.Prelude -import GHC.Data.OsPath +import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST +import GHC.Driver.DynFlags +import GHC.Platform.ArchOS +import GHC.Types.Unique.Map +import GHC.Unit.Database import GHC.Unit.Info -import GHC.Utils.Outputable +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic -import Data.IORef (IORef) +import Control.Monad +import Data.Char +import Data.IORef import Data.IORef qualified as IORef -import Data.Map.Strict +import Data.List (sortBy) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as Set +import System.Directory +import System.Environment (getEnv) +import System.FilePath as FilePath -- ---------------------------------------------------------------------------- -- ExternalUnitDatabaseCache @@ -102,3 +135,273 @@ data UnitDatabase unit = UnitDatabase instance (Outputable u) => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each unit, a mapping from uid -> i indicates that this +-- unit was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- units that were defined later on the command line, if there +-- is an ambiguity. +type UnitPrecedenceMap = UniqMap UnitId Int + +-- | Given a list of databases, merge them together, where +-- units with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: Logger -> [UnitDatabase UnitId] + -> IO (UnitInfoMap, UnitPrecedenceMap) +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] + where + merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do + debugTraceMsg logger 2 $ + text "loading package database" <+> ppr db_path + when (logVerbAtLeast logger 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set UnitId + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: UnitInfoMap + pkg_map' = pkg_map `plusUniqMap` db_map + + prec_map' :: UnitPrecedenceMap + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the units +-- in later unit database. +compareByPreference + :: UnitPrecedenceMap + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + = case comparing unitPackageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') + -- Prefer the unit from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + +-- ----------------------------------------------------------------------------- +-- Reading the unit database(s) + +data UnitDbConfig = UnitDbConfig + { unitDbConfigFlagsDB :: [PackageDBFlag] + , unitDbConfigProgramName :: String + , unitDbConfigDBName :: FilePath + , unitDbConfigPlatformArchOS :: ArchOS + , unitDbConfigGlobalDB :: FilePath + , unitDbConfigGHCDir :: FilePath + } + +readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId] +readUnitDatabases logger db_cache cfg = do + conf_refs <- getUnitDbRefs cfg + confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs + mapM (readOrGetUnitDatabase logger db_cache cfg) confs + + +getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef] +getUnitDbRefs cfg = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (unitDbConfigProgramName cfg) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (unitDbConfigFlagsDB cfg)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolveUnitDatabase :: UnitDbConfig -> PkgDbRef -> IO (Maybe OsPath) +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitDbConfigGlobalDB cfg +resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do + dir <- versionedAppDir (unitDbConfigProgramName cfg) (unitDbConfigPlatformArchOS cfg) + let pkgconf = dir </> unitDbConfigDBName cfg + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero +resolveUnitDatabase _ (PkgDbPath name) = return $ Just name + +-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. +readOrGetUnitDatabase :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger db_cache cfg conf_file = + readExternalUnitDatabase db_cache conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase db_cache new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. +readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId) +readUnitDatabase logger cfg conf_file = do + isdir <- OsPath.doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- OsPath.doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ show conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ show conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = OsPath.dropTrailingPathSeparator conf_file + top_dir = OsPath.unsafeEncodeUtf (unitDbConfigGHCDir cfg) + pkgroot = OsPath.takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) + proto_pkg_configs + -- + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 + where + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") + cache_exists <- OsPath.doesFileExist filename + if cache_exists + then do + debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg logger 2 $ text "There is no package.cache in" + <+> ppr conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) + <$> OsPath.getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg logger 3 $ text "There are no .conf files in" + <+> ppr conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ show conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" + direxists <- OsPath.doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +mungeUnitInfo :: OsPath -> OsPath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeBytecodeLibFields + . mungeLibDirFields + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) + +mungeLibDirFields :: UnitInfo -> UnitInfo +mungeLibDirFields pkg = + pkg { + unitLibraryDynDirs = case unitLibraryDynDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } ===================================== compiler/GHC/Unit/External/Index.hs ===================================== @@ -0,0 +1,238 @@ +module GHC.Unit.External.Index ( + -- * The 'UnitIndexCache'. + -- A mutable wrapper around 'UnitIndex' + UnitIndexCache(..), + initUnitIndexCache, + readUnitIndex, + modifyUnitIndexCache, + clearUnitIndexCache, + -- * 'UnitIndex' + UnitIndex, + emptyUnitIndex, + wiringMap, + unwiringMap, + globalUnits, + setWireMap, + wireMapExists, + addUnitInfoMap, + -- * 'GlobalUnitInfoMap' + GlobalUnitInfoMap, + lookupGlobalUnitInfoMap, + emptyGlobalUnitInfoMap, + mkGlobalUnitInfoMap, + -- * 'GlobalUnitKey' + GlobalUnitKey, + UnitAbiHash, + mkGlobalUnitKey, + globalUnitKeyFromUnitInfo, + -- * Wired-in units + unwireUnit, + updateWiredInUnits, + updateWiredInUnitsInUnitInfo, + updateWiredInUnitIdInModule, +) where + +import GHC.Prelude + +import GHC.Data.ShortText qualified as ST +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.External.Wired +import GHC.Unit.Info +import GHC.Unit.Types + +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map + +-- ---------------------------------------------------------------------------- +-- UnitIndex +-- ---------------------------------------------------------------------------- + +newtype UnitIndexCache = UnitIndexCache + { uic_index :: IORef UnitIndex + } + +initUnitIndexCache :: IO UnitIndexCache +initUnitIndexCache = + UnitIndexCache <$> IORef.newIORef emptyUnitIndex + +readUnitIndex :: UnitIndexCache -> IO UnitIndex +readUnitIndex eudc = + IORef.readIORef (uic_index eudc) + +modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO () +modifyUnitIndexCache eudc f = + IORef.modifyIORef' (uic_index eudc) f + +clearUnitIndexCache :: UnitIndexCache -> IO () +clearUnitIndexCache eudc = + modifyUnitIndexCache eudc (const emptyUnitIndex) + +data UnitIndex = UnitIndex + { ui_wireMap :: !WireMap + -- ^ A mapping from database unit keys to wired in unit ids. + , ui_unwireMap :: !UnwireMap + -- ^ A mapping from wired in unit ids to unit keys from the database. + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: document + } + +wiringMap :: UnitIndex -> WireMap +wiringMap = ui_wireMap + +unwiringMap :: UnitIndex -> UnwireMap +unwiringMap = ui_unwireMap + +globalUnits :: UnitIndex -> GlobalUnitInfoMap +globalUnits = ui_unitInfoMap + +emptyUnitIndex :: UnitIndex +emptyUnitIndex = UnitIndex + { ui_wireMap = emptyWireMap + , ui_unwireMap = emptyUnwireMap + , ui_unitInfoMap = emptyGlobalUnitInfoMap + } + +setWireMap :: WireMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = unwiringMapFromWireMap wired_map + } + +wireMapExists :: UnitIndex -> Bool +wireMapExists unit_index = + not $ isWireMapEmpty (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = + -- Order should not matter, either it is exactly the same 'UnitInfo', + -- or a new one. + GlobalUnitInfoMap $ plusUniqMap_C Map.union newEntriesMap oldMap + } + where + GlobalUnitInfoMap newEntriesMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map + GlobalUnitInfoMap oldMap = ui_unitInfoMap unit_index + +-- ---------------------------------------------------------------------------- +-- GlobalUnitInfoMap +-- ---------------------------------------------------------------------------- + +type UnitAbiHash = ST.ShortText + +-- | A +newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo)) + +lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo +lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) (GlobalUnitInfoMap globalMap) = + case lookupUniqMap globalMap uid of + Nothing -> Nothing + Just sameUnitId -> Map.lookup abiHash sameUnitId + +mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap +mkGlobalUnitInfoMap unitInfos = + GlobalUnitInfoMap $ listToUniqMap_C Map.union (map mkEntry unitInfos) + where + mkEntry (uid, v) = (uid, Map.singleton (unitAbiHash v) v) + +emptyGlobalUnitInfoMap :: GlobalUnitInfoMap +emptyGlobalUnitInfoMap = GlobalUnitInfoMap emptyUniqMap + +-- ---------------------------------------------------------------------------- +-- GlobalUnitKey +-- ---------------------------------------------------------------------------- + +-- | A 'GlobalUnitKey' is a key that can globally identify a 'UnitInfo', not just +-- in the 'UnitInfoMap'. +data GlobalUnitKey = + GlobalUnitKey + !UnitId -- ^ Unit Id of the 'UnitInfo' + !UnitAbiHash -- ^ ABI hash of the 'UnitInfo' + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo ui = mkGlobalUnitKey (unitId ui) (unitAbiHash ui) + +mkGlobalUnitKey :: UnitId -> UnitAbiHash -> GlobalUnitKey +mkGlobalUnitKey = GlobalUnitKey + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +-- | Given a wired-in 'Unit', "unwire" it into the 'Unit' +-- that it was recorded as in the package database. +unwireUnit :: UnitIndex -> Unit -> Unit +unwireUnit state uid@(RealUnit (Definite def_uid)) = + maybe uid (RealUnit . Definite) (lookupUnwireMap def_uid (unwiringMap state)) +unwireUnit _ uid = uid + +updateWiredInUnits :: WireMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WireMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_wired_in_pkg wiredInUnitId pkg = + pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (updateWiredInUnitIdInModule wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupWireMap (unitId pkg) wiredInMap of + Just wiredIn -> + case lookupGlobalUnitInfoMap (mkGlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps pkg + in + Left $ seqUnitInfo updated_pkg updated_pkg + +-- Helper functions for rewiring Module and Unit. These +-- rewrite Units of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in GHC.Builtin.Names. + +updateWiredInUnitIdInModule :: WireMap -> Module -> Module +updateWiredInUnitIdInModule wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WireMap -> Unit -> Unit +upd_wired_in_uid wiredInMap u = case u of + HoleUnit -> HoleUnit + RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) + VirtUnit indef_uid -> + VirtUnit $ mkInstantiatedUnit + (instUnitInstanceOf indef_uid) + (map (\(x,y) -> (x,updateWiredInUnitIdInModule wiredInMap y)) (instUnitInsts indef_uid)) + +upd_wired_in :: WireMap -> UnitId -> UnitId +upd_wired_in wiredInMap key + | Just key' <- lookupWireMap key wiredInMap = key' + | otherwise = key ===================================== compiler/GHC/Unit/External/ModuleOrigin.hs ===================================== @@ -0,0 +1,110 @@ +module GHC.Unit.External.ModuleOrigin ( + ModuleOrigin(..), + fromExposedModules, + fromReexportedModules, + fromFlag, + originVisible, + originEmpty, +) where + +import GHC.Prelude +import GHC.Unit.External.Validate +import GHC.Unit.Info +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Data.Semigroup as Semigroup + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigUnit :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . mkUnit) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . mkUnit) rhs)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + g Nothing x = x + g x Nothing = x + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ + text "x: " <> ppr x $$ text "y: " <> ppr y + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False ===================================== compiler/GHC/Unit/External/Providers.hs ===================================== @@ -0,0 +1,186 @@ +module GHC.Unit.External.Providers ( + ModuleNameProvidersMap, + pprModuleMap, + mkModuleNameProvidersMap, + mkUnusableModuleNameProvidersMap, +) where + +import GHC.Prelude + +import GHC.Data.Maybe +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Query +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic + +-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' + +type ModuleNameProvidersMap = + UniqMap ModuleName (UniqMap Module ModuleOrigin) + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (nonDetUniqMapToList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from ModuleName to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: Logger + -> Bool + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap logger allowVirtualUnits pkg_map vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_map is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_map multiple times to the actual + -- ModuleNameProvidersMap. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended + where + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map + + default_vis = listToUniqMap + [ (mkUnit pkg, mempty) + | (_, pkg) <- nonDetUniqMapToList pkg_map + -- Exclude specific instantiations of an indefinite + -- package + , unitIsIndefinite pkg || null (unitInstantiations pkg) + ] + + emptyMap = emptyUniqMap + setOrigins m os = fmap (const os) m + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, UniqMap Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (renderWithContext + (log_default_user_context (logFlags logger)) + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + (pk', m', fromReexportedModules e pkg) + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = mkUnit pkg + unit_lookup uid = lookupUnit' allowVirtualUnits pkg_map uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = unitExposedModules pkg + hidden_mods = unitHiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap unusables = + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables + where + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] + + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. + + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) +addListTo = foldl' merge + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v + +-- | Create a singleton module mapping +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) ===================================== compiler/GHC/Unit/External/Query.hs ===================================== @@ -0,0 +1,41 @@ +module GHC.Unit.External.Query ( + -- * Query the 'UnitInfoMap' + lookupUnit', + lookupUnitId', +) where + +import GHC.Prelude + +import GHC.Types.Unique.Map +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Module + +-- | A more specialized interface, which doesn't require a 'UnitState' (so it +-- can be used while we're initializing 'DynFlags') +-- +-- Parameters: +-- * a boolean specifying whether or not to look for on-the-fly renamed interfaces +-- * a 'UnitInfoMap' +lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo +lookupUnit' allowOnTheFlyInst pkg_map u = case u of + HoleUnit -> error "Hole unit" + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) + VirtUnit i + | allowOnTheFlyInst + -> -- lookup UnitInfo of the indefinite unit to be instantiated and + -- instantiate it on-the-fly + fmap (renameUnitInfo pkg_map (instUnitInsts i)) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) + + | otherwise + -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite + -- units. Even if they are real, installed units, they can't use the + -- `RealUnit` constructor (it is reserved for definite units) so we use + -- the `VirtUnit` constructor. + lookupUniqMap pkg_map (virtualUnitId i) + + +-- | Find the unit we know about with the given unit id, if any +lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnitId' db uid = lookupUniqMap db uid ===================================== compiler/GHC/Unit/External/Substitution.hs ===================================== @@ -0,0 +1,61 @@ +module GHC.Unit.External.Substitution ( + -- * Substitution and module renaming + ShHoleSubst, + renameHoleModule', + renameHoleUnit', + renameUnitInfo, +) where + +import GHC.Prelude + +import GHC.Unit.Module +import GHC.Unit.Info +import GHC.Types.Unique.FM +import GHC.Types.Unique.DFM +import GHC.Types.Unique.DSet + +-- ----------------------------------------------------------------------------- +-- Module renaming + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Rename a 'UnitInfo' according to some module instantiation. +renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo +renameUnitInfo pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) + in conf { + unitInstantiations = new_insts, + unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (unitExposedModules conf) + } + + +-- | Like 'renameHoleModule', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnit' pkg_map env (moduleUnit m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' +-- so it can be used by "GHC.Unit.State". +renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit +renameHoleUnit' pkg_map env uid = + case uid of + (VirtUnit + InstantiatedUnit{ instUnitInstanceOf = cid + , instUnitInsts = insts + , instUnitHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + else mkVirtUnit cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid ===================================== compiler/GHC/Unit/External/Validate.hs ===================================== @@ -0,0 +1,383 @@ +module GHC.Unit.External.Validate ( + -- * Validation of unit databases + validateDatabase, + reportUnusable, + UnusableUnits, + UnusableUnit(..), + UnusableUnitReason(..), + pprReason, + -- * Package resolver + findPackages, + selectPackages, + -- * Unit database closure validation + UnitErr(..), + mayThrowUnitErr, + closeUnitDeps, + closeUnitDeps', + -- * Utils + ignoreUnits, + pprFlag, +) where + +import GHC.Prelude + +import Control.Monad +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (partition) +import GHC.Data.Maybe +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.External.Database +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Outputable qualified as Outputable +import GHC.Utils.Panic + +-- ----------------------------------------------------------------------------- +-- Database validation + +-- | Validates a database, removing unusable units from it +-- (this includes removing units that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken units (dangling dependencies) +-- 2. Remove all units that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all units which have deps with mismatching ABIs +-- +validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap + -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) +validateDatabase flagsIgnored pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse flagsIgnored -- (unitConfigFlagsIgnored cfg) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] + + -- Find broken units + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (nonDetEltsUniqMap pkg_map1) + (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive units + sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) + | pkg <- nonDetEltsUniqMap pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out units whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (nonDetEltsUniqMap pkg_map4) + (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] + + +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) + +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + +-- | The reason why a unit is unusable. +data UnusableUnitReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This unit transitively depends on a unit that was never present + -- in any of the provided databases. + | BrokenDependencies [UnitId] + -- | This unit transitively depends on a unit involved in a cycle. + -- Note that the list of 'UnitId' reports the direct dependencies + -- of this unit that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [UnitId] + -- | This unit transitively depends on a unit which was ignored. + | IgnoredDependencies [UnitId] + -- | This unit transitively depends on a unit which was + -- shadowed by an ABI-incompatible unit. + | ShadowedDependencies [UnitId] + +instance Outputable UnusableUnitReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +pprReason :: SDoc -> UnusableUnitReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportUnusable :: Logger -> UnusableUnits -> IO () +reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg logger 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ----------------------------------------------------------------------------- +-- Package Finding + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: UnitPrecedenceMap + -> UnitInfoMap + -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + [UnitInfo] +findPackages prec_map pkg_map arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if matchingStr str p + then Just p + else Nothing + finder (UnitIdArg uid) p + = case uid of + RealUnit (Definite iuid) + | iuid == unitId p + -> Just p + VirtUnit inst + | instUnitInstanceOf inst == unitId p + -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) + _ -> Nothing + +selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] + -> UnusableUnits + -> Either [(UnitInfo, UnusableUnitReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- ----------------------------------------------------------------------------- +-- Ignore units + +ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing unit is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == unitPackageIdString p + || str == unitPackageNameString p + +matchingId :: UnitId -> UnitInfo -> Bool +matchingId uid p = uid == unitId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- ---------------------------------------------------------------------------- +-- +-- Closures +-- + + +-- | Takes a list of UnitIds (and their "parent" dependency, used for error +-- messages), and returns the list with dependencies included, in reverse +-- dependency order (a units appears before those it depends on). +closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps + +-- | Similar to closeUnitDeps but takes a list of already loaded units as an +-- additional argument. +closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps + +-- | Add a UnitId and those it depends on (recursively) to the given list of +-- UnitIds if they are not already in it. Return a list in reverse dependency +-- order (a unit appears before those it depends on). +-- +-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). +-- It it's not found, the optional parent unit is used to return a more precise +-- error message ("dependency of <PARENT>"). +add_unit :: UnitInfoMap + -> [UnitId] + -> UnitId + -> Maybe UnitId + -> MaybeErr UnitErr [UnitId] +add_unit pkg_map ps p mb_parent + | p `elem` ps = return ps -- Check if we've already added this unit + | otherwise = case lookupUnitId' pkg_map p of + Nothing -> Failed (CloseUnitErr p mb_parent) + Just info -> do + -- Add the unit's dependents also + ps' <- foldM add_unit_key ps (unitDepends info) + return (p : ps') + where + add_unit_key xs key + = add_unit pkg_map xs key (Just p) +data UnitErr + = CloseUnitErr !UnitId !(Maybe UnitId) + | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] + | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] + +mayThrowUnitErr :: MaybeErr UnitErr a -> IO a +mayThrowUnitErr = \case + Failed e -> throwGhcExceptionIO + $ CmdLineError + $ renderWithContext defaultSDocContext + $ withPprStyle defaultUserStyle + $ ppr e + Succeeded a -> return a + +instance Outputable UnitErr where + ppr = \case + CloseUnitErr p mb_parent + -> (text "unknown unit:" <+> ppr p) + <> case mb_parent of + Nothing -> Outputable.empty + Just parent -> space <> parens (text "dependency of" + <+> ftext (unitIdFS parent)) + PackageFlagErr flag reasons + -> flag_err (pprFlag flag) reasons + + TrustFlagErr flag reasons + -> flag_err (pprTrustFlag flag) reasons + where + flag_err flag_doc reasons = + text "cannot satisfy " + <> flag_doc + <> (if null reasons then Outputable.empty else text ": ") + $$ nest 4 (vcat (map ppr_reason reasons) $$ + text "(use -v for more information)") + + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'UnitId' to +-- the 'UnitId's which have a dependency on it. +type RevIndex = UniqMap UnitId [UnitId] + +-- | Compute the reverse dependency index of a unit database. +reverseDeps :: UnitInfoMap -> RevIndex +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db + where + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] + +-- | Given a list of 'UnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those units, plus any units which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removeUnits :: [UnitId] -> RevIndex + -> UnitInfoMap + -> (UnitInfoMap, [UnitInfo]) +removeUnits uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' +-- which correspond to units that do not exist in the index. +depsNotAvailable :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) + +-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in +-- 'unitAbiDepends' which correspond to units that do not exist, OR have +-- mismatching ABIs. +depsAbiMismatch :: UnitInfoMap + -> UnitInfo + -> [UnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid + = unitAbiHash dep_pkg == abi + | otherwise + = False ===================================== compiler/GHC/Unit/External/Visibility.hs ===================================== @@ -0,0 +1,72 @@ +module GHC.Unit.External.Visibility ( + VisibilityMap, + UnitVisibility(..), +) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Driver.DynFlags +import GHC.Types.Unique.Map +import GHC.Unit.Module +import GHC.Utils.Outputable as Outputable + +import Control.Applicative +import Data.Monoid (First (..)) +import Data.Semigroup qualified as Semigroup +import Data.Set (Set) +import Data.Set qualified as Set + +-- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. +type VisibilityMap = UniqMap Unit UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'Unit'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name associated with the 'Unit'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Maybe PackageArg + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) + , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = emptyUniqMap + , uv_explicit = Nothing + } + mappend = (Semigroup.<>) + ===================================== compiler/GHC/Unit/External/Wired.hs ===================================== @@ -0,0 +1,140 @@ +module GHC.Unit.External.Wired ( + -- * 'WireMap' + WireMap, + emptyWireMap, + isWireMapEmpty, + lookupWireMap, + listWireMap, + -- * 'UnwireMap' + UnwireMap, + emptyUnwireMap, + lookupUnwireMap, + unwiringMapFromWireMap, + -- * Creating 'WireMap' + findWiredInUnits, +) where + +import GHC.Prelude + +import GHC.Unit.External.Database +import GHC.Unit.External.Visibility + +import GHC.Data.Maybe +import GHC.Types.Unique.Map +import GHC.Unit.Database +import GHC.Unit.Info +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Outputable as Outputable + +-- | The 'WireMap' records the mapping from the 'UnitId' of on-disk 'UnitInfo' +-- to the 'UnitId' of the 'wiredInMap'. +-- +-- See 'wiredInUnitIds' for the set of wired-in units. +-- +newtype WireMap = + WireMap (UniqMap UnitId UnitId) + +emptyWireMap :: WireMap +emptyWireMap = WireMap emptyUniqMap + +isWireMapEmpty :: WireMap -> Bool +isWireMapEmpty (WireMap wmap) = isNullUniqMap wmap + +lookupWireMap :: UnitId -> WireMap -> Maybe UnitId +lookupWireMap uid (WireMap wmap) = lookupUniqMap wmap uid + +listWireMap :: WireMap -> [(UnitId, UnitId)] +listWireMap (WireMap wmap) = nonDetUniqMapToList wmap + +-- | The reverse of 'WireMap'. +-- Records the mapping from the wired-in 'UnitId' to the on-disk 'UnitId'. +newtype UnwireMap = + UnwireMap (UniqMap UnitId UnitId) + +emptyUnwireMap :: UnwireMap +emptyUnwireMap = UnwireMap emptyUniqMap + +unwiringMapFromWireMap :: WireMap -> UnwireMap +unwiringMapFromWireMap (WireMap wired_map) = + UnwireMap $ listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + +lookupUnwireMap :: UnitId -> UnwireMap -> Maybe UnitId +lookupUnwireMap uid (UnwireMap wmap) = lookupUniqMap wmap uid + +-- ----------------------------------------------------------------------------- +-- Wired-in units +-- +-- See Note [Wired-in units] in GHC.Unit.Types + +findWiredInUnits + :: Logger + -> UnitPrecedenceMap + -> [UnitInfo] -- database + -> VisibilityMap -- info on what units are visible + -- for wired in selection + -> IO WireMap -- map from unit id to wired identity +findWiredInUnits logger prec_map pkgs vis_map = do + -- Now we must find our wired-in units, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in units] in GHC.Unit.Types + let + matches :: UnitInfo -> UnitId -> Bool + pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) + findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] + where + all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + + notfound = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " not found." + return Nothing + pick :: UnitInfo -> IO (UnitId, UnitInfo) + pick pkg = do + debugTraceMsg logger 2 $ + text "wired-in package " + <> ftext (unitIdFS wired_pkg) + <> text " mapped to " + <> ppr (unitId pkg) + return (wired_pkg, pkg) + + + mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap + [ (unitId realUnitInfo, wiredInUnitId) + | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs + , not (unitIsIndefinite realUnitInfo) + ] + + return $ WireMap wiredInMap ===================================== compiler/GHC/Unit/Info.hs ===================================== @@ -5,11 +5,14 @@ module GHC.Unit.Info ( GenericUnitInfo (..) , GenUnitInfo , UnitInfo + , UnitInfoMap , UnitKey (..) , UnitKeyInfo , mkUnitKeyInfo , mapUnitInfo , mkUnitPprInfo + , evaluateUnitInfo + , seqUnitInfo , mkUnit @@ -53,6 +56,8 @@ import Data.Containers.ListUtils (nubOrd) import Data.Version import Data.Bifunctor import Data.List (isPrefixOf, stripPrefix) +import GHC.Types.Unique.Map +import Control.Exception (evaluate) -- | Information about an installed unit @@ -73,6 +78,9 @@ type UnitKeyInfo = GenUnitInfo UnitKey -- UnitId) type UnitInfo = GenUnitInfo UnitId +-- TODO @fendor +type UnitInfoMap = UniqMap UnitId UnitInfo + -- | Convert a DbUnitInfo (read from a package database) into `UnitKeyInfo` mkUnitKeyInfo :: DbUnitInfo -> UnitKeyInfo mkUnitKeyInfo = mapGenericUnitInfo @@ -250,3 +258,21 @@ unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibrar expandTag t | null t = "" | otherwise = '_':t + +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) + +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -4,14 +4,6 @@ -- | Unit manipulation module GHC.Unit.State ( module GHC.Unit.Info, - - UnitIndex(..), - initUnitIndex, - setWireMap, - isWireMapEmpty, - addUnitInfoMap, - -- lookupUnitInfoMap, - -- * Reading the package config, and processing cmdline args UnitState(..), UnitDatabase (..), @@ -26,7 +18,6 @@ module GHC.Unit.State ( listUnitInfo, -- * Querying the package config - UnitInfoMap, lookupUnit, lookupUnit', unsafeLookupUnit, @@ -90,50 +81,45 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Unit.Database +import GHC.Unit.Home import GHC.Unit.Info -import GHC.Unit.Ppr -import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Home +import GHC.Unit.Ppr -import GHC.Types.Unique.FM +import GHC.Unit.External.Database +import GHC.Unit.External.Index +import GHC.Unit.External.ModuleOrigin +import GHC.Unit.External.Providers +import GHC.Unit.External.Query +import GHC.Unit.External.Substitution +import GHC.Unit.External.Validate +import GHC.Unit.External.Visibility +import GHC.Unit.External.Wired + +import GHC.Types.PkgQual import GHC.Types.Unique.DFM -import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM import GHC.Types.Unique.Map -import GHC.Types.Unique -import GHC.Types.PkgQual +import GHC.Types.Unique.Set -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable as Outputable -import GHC.Data.Maybe - -import System.Environment ( getEnv ) import GHC.Data.FastString -import GHC.Data.OsPath ( OsPath ) -import qualified GHC.Data.OsPath as OsPath -import qualified GHC.Data.ShortText as ST -import GHC.Utils.Logger +import GHC.Data.Maybe +import GHC.Data.OsPath qualified as OsPath +import GHC.Data.ShortText qualified as ST import GHC.Utils.Error -import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic -import System.Directory -import System.FilePath as FilePath import Control.Monad import Data.Containers.ListUtils (nubOrd) -import Data.Graph (stronglyConnComp, SCC(..)) -import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, sortOn, sort ) -import Data.Set (Set) -import Data.Monoid (First(..)) -import qualified Data.Semigroup as Semigroup -import qualified Data.Set as Set -import Control.Applicative -import GHC.Unit.External.Database -import Data.IORef import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.Graph (SCC (..)) +import Data.List (intersperse, partition, sort, sortOn) +import Data.Monoid (First (..)) +import Data.Set (Set) +import Data.Set qualified as Set -- --------------------------------------------------------------------------- -- The Unit state @@ -179,162 +165,6 @@ import qualified Data.Map.Strict as Map -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! -data ModuleOrigin = - -- | Module is hidden, and thus never will be available for import. - -- (But maybe the user didn't realize), so we'll still keep track - -- of these modules.) - ModHidden - - -- | Module is unavailable because the unit is unusable. - | ModUnusable !UnusableUnit - - -- | Module is public, and could have come from some places. - | ModOrigin { - -- | @Just False@ means that this module is in - -- someone's @exported-modules@ list, but that package is hidden; - -- @Just True@ means that it is available; @Nothing@ means neither - -- applies. - fromOrigUnit :: Maybe Bool - -- | Is the module available from a reexport of an exposed package? - -- There could be multiple. - , fromExposedReexport :: [UnitInfo] - -- | Is the module available from a reexport of a hidden package? - , fromHiddenReexport :: [UnitInfo] - -- | Did the module export come from a package flag? (ToDo: track - -- more information. - , fromPackageFlag :: Bool - } - --- | A unusable unit module origin -data UnusableUnit = UnusableUnit - { uuUnit :: !Unit -- ^ Unusable unit - , uuReason :: !UnusableUnitReason -- ^ Reason - , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? - } - -instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" - ppr (ModUnusable _) = text "unusable module" - ppr (ModOrigin e res rhs f) = sep (punctuate comma ( - (case e of - Nothing -> [] - Just False -> [text "hidden package"] - Just True -> [text "exposed package"]) ++ - (if null res - then [] - else [text "reexport by" <+> - sep (map (ppr . mkUnit) res)]) ++ - (if null rhs - then [] - else [text "hidden reexport by" <+> - sep (map (ppr . mkUnit) rhs)]) ++ - (if f then [text "package flag"] else []) - )) - --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False - --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is exposed, and --- also its 'UnitInfo'. -fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False - --- | Smart constructor for a module which was bound by a package flag. -fromFlag :: ModuleOrigin -fromFlag = ModOrigin Nothing [] [] True - -instance Semigroup ModuleOrigin where - x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - g Nothing x = x - g x Nothing = x - - x <> y = pprPanic "ModOrigin: module origin mismatch" $ - text "x: " <> ppr x $$ text "y: " <> ppr y - -instance Monoid ModuleOrigin where - mempty = ModOrigin Nothing [] [] False - mappend = (Semigroup.<>) - --- | Is the name from the import actually visible? (i.e. does it cause --- ambiguity, or is it only relevant when we're making suggestions?) -originVisible :: ModuleOrigin -> Bool -originVisible ModHidden = False -originVisible (ModUnusable _) = False -originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f - --- | Are there actually no providers for this module? This will never occur --- except when we're filtering based on package imports. -originEmpty :: ModuleOrigin -> Bool -originEmpty (ModOrigin Nothing [] [] False) = True -originEmpty _ = False - --- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = UniqMap Unit UnitVisibility - --- | 'UnitVisibility' records the various aspects of visibility of a particular --- 'Unit'. -data UnitVisibility = UnitVisibility - { uv_expose_all :: Bool - -- ^ Should all modules in exposed-modules should be dumped into scope? - , uv_renamings :: [(ModuleName, ModuleName)] - -- ^ Any custom renamings that should bring extra 'ModuleName's into - -- scope. - , uv_package_name :: First FastString - -- ^ The package name associated with the 'Unit'. This is used - -- to implement legacy behavior where @-package foo-0.1@ implicitly - -- hides any packages named @foo@ - , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) - -- ^ The signatures which are contributed to the requirements context - -- from this unit ID. - , uv_explicit :: Maybe PackageArg - -- ^ Whether or not this unit was explicitly brought into scope, - -- as opposed to implicitly via the 'exposed' fields in the - -- package database (when @-hide-all-packages@ is not passed.) - } - -instance Outputable UnitVisibility where - ppr (UnitVisibility { - uv_expose_all = b, - uv_renamings = rns, - uv_package_name = First mb_pn, - uv_requirements = reqs, - uv_explicit = explicit - }) = ppr (b, rns, mb_pn, reqs, explicit) - -instance Semigroup UnitVisibility where - uv1 <> uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) - , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 - } - -instance Monoid UnitVisibility where - mempty = UnitVisibility - { uv_expose_all = False - , uv_renamings = [] - , uv_package_name = First Nothing - , uv_requirements = emptyUniqMap - , uv_explicit = Nothing - } - mappend = (Semigroup.<>) - - -- | Unit configuration data UnitConfig = UnitConfig { unitConfigPlatformArchOS :: !ArchOS -- ^ Platform arch and OS @@ -358,8 +188,6 @@ data UnitConfig = UnitConfig , unitConfigHideAll :: !Bool -- ^ Hide all units by default , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default - , unitConfigDBCache :: !(ExternalUnitDatabaseCache UnitId) - -- command-line flags , unitConfigFlagsDB :: [PackageDBFlag] -- ^ Unit databases flags , unitConfigFlagsExposed :: [PackageFlag] -- ^ Exposed units @@ -369,8 +197,8 @@ data UnitConfig = UnitConfig , unitConfigHomeUnits :: Set.Set UnitId } -initUnitConfig :: DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> UnitConfig -initUnitConfig dflags cached_dbs home_units = +initUnitConfig :: DynFlags -> Set.Set UnitId -> UnitConfig +initUnitConfig dflags home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags !hu_instantiations = homeUnitInstantiations_ dflags @@ -407,7 +235,6 @@ initUnitConfig dflags cached_dbs home_units = , unitConfigHideAll = gopt Opt_HideAllPackages dflags , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags - , unitConfigDBCache = cached_dbs , unitConfigFlagsDB = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags , unitConfigFlagsExposed = packageFlags dflags , unitConfigFlagsIgnored = ignorePackageFlags dflags @@ -422,77 +249,6 @@ initUnitConfig dflags cached_dbs home_units = offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p)) offsetPackageDb _ p = p - --- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and --- its 'ModuleOrigin'). --- --- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one --- origin for a given 'Module' - -type ModuleNameProvidersMap = - UniqMap ModuleName (UniqMap Module ModuleOrigin) - -data GlobalUnitKey = - GlobalUnitKey - !UnitId -- ^ Unit Id of the 'UnitInfo' - !ST.ShortText - -globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey -globalUnitKeyFromUnitInfo ui = GlobalUnitKey (unitId ui) (unitAbiHash ui) - -type GlobalUnitInfoMap = UniqMap UnitId (Map ST.ShortText UnitInfo) - -lookupGlobalUnitInfoMap :: GlobalUnitKey -> GlobalUnitInfoMap -> Maybe UnitInfo -lookupGlobalUnitInfoMap (GlobalUnitKey uid abiHash) globalMap = - case lookupUniqMap globalMap uid of - Nothing -> Nothing - Just sameUnitId -> Map.lookup abiHash sameUnitId - -mkGlobalUnitInfoMap :: [(UnitId, UnitInfo)] -> GlobalUnitInfoMap -mkGlobalUnitInfoMap unitInfos = - listToUniqMap_C Map.union . map (\(uid, v) -> (uid, Map.singleton (unitAbiHash v) v)) $ unitInfos - - -data UnitIndex = UnitIndex - { ui_wireMap :: !WiringMap - -- ^ TODO @fendor: document global property - , ui_unwireMap :: !UnwiringMap - -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: !GlobalUnitInfoMap - -- ^ TODO @fendor: document - } - -initUnitIndex :: UnitIndex -initUnitIndex = UnitIndex - { ui_wireMap = emptyUniqMap - , ui_unwireMap = emptyUniqMap - , ui_unitInfoMap = emptyUniqMap - } - -setWireMap :: WiringMap -> UnitIndex -> UnitIndex -setWireMap wired_map unit_index = - unit_index - { ui_wireMap = wired_map - , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] - } - -isWireMapEmpty :: UnitIndex -> Bool -isWireMapEmpty unit_index = - isNullUniqMap (ui_wireMap unit_index) - -addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex -addUnitInfoMap unit_info_map unit_index = - unit_index - { ui_unitInfoMap = plusUniqMap_C Map.union globalMap (ui_unitInfoMap unit_index) - } - where - globalMap :: GlobalUnitInfoMap - globalMap = mkGlobalUnitInfoMap $ nonDetUniqMapToList unit_info_map - --- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo --- lookupUnitInfoMap unit_index unit_id = --- lookupUniqMap (ui_unitInfoMap unit_index) unit_id - data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects @@ -500,12 +256,18 @@ data UnitState = UnitState { -- is adjusted at runtime. (In particular, some units in this map -- may have the 'exposed' flag be 'False'.) -- - -- TODO @fendor: All values are shared with 'UnitIndex.ui_unitInfoMap'. + -- All values are shared with 'UnitIndex'.'globalUnits'. unitInfoMap :: UnitInfoMap, - -- | Local overlay for the unit info so that sharing is more accurate - trustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet - distrustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet + -- | Set of units that we trust. + -- + -- Local overlay of 'UnitInfo'. + trustedUnits :: UniqSet UnitId, + + -- | Set of units that we distrust. + -- + -- Local overlay of 'UnitInfo'. + distrustedUnits :: UniqSet UnitId, -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same -- package name (e.g. different instantiations), then we return one of them... @@ -513,12 +275,6 @@ data UnitState = UnitState { -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- -- | A mapping from database unit keys to wired in unit ids. - -- wireMap :: WiringMap, - - -- -- | A mapping from wired in unit ids to unit keys from the database. - -- unwireMap :: UnwiringMap, - -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit -- is always mentioned before the units it depends on. @@ -559,8 +315,8 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, - trustedUnits = Set.empty, - distrustedUnits = Set.empty, + trustedUnits = emptyUniqSet, + distrustedUnits = emptyUniqSet, packageNameMap = emptyUFM, -- wireMap = emptyUniqMap, -- unwireMap = emptyUniqMap, @@ -573,45 +329,14 @@ emptyUnitState = UnitState { allowVirtualUnits = False } -type UnitInfoMap = UniqMap UnitId UnitInfo - -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo lookupUnit pkgs = lookupUnit' (allowVirtualUnits pkgs) (unitInfoMap pkgs) --- | A more specialized interface, which doesn't require a 'UnitState' (so it --- can be used while we're initializing 'DynFlags') --- --- Parameters: --- * a boolean specifying whether or not to look for on-the-fly renamed interfaces --- * a 'UnitInfoMap' -lookupUnit' :: Bool -> UnitInfoMap -> Unit -> Maybe UnitInfo -lookupUnit' allowOnTheFlyInst pkg_map u = case u of - HoleUnit -> error "Hole unit" - RealUnit i -> lookupUniqMap pkg_map (unDefinite i) - VirtUnit i - | allowOnTheFlyInst - -> -- lookup UnitInfo of the indefinite unit to be instantiated and - -- instantiate it on-the-fly - fmap (renameUnitInfo pkg_map (instUnitInsts i)) - (lookupUniqMap pkg_map (instUnitInstanceOf i)) - - | otherwise - -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite - -- units. Even if they are real, installed units, they can't use the - -- `RealUnit` constructor (it is reserved for definite units) so we use - -- the `VirtUnit` constructor. - lookupUniqMap pkg_map (virtualUnitId i) - -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo lookupUnitId state uid = lookupUnitId' (unitInfoMap state) uid --- | Find the unit we know about with the given unit id, if any -lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnitId' db uid = lookupUniqMap db uid - - -- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of @@ -691,20 +416,21 @@ mkUnitInfoMap infos = foldl' add emptyUniqMap infos listUnitInfo :: UnitState -> [UnitInfo] listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool -isUnitTrusted ue u = - Set.member (toUnitId u) (trustedUnits ue) && (Set.notMember (toUnitId u) (distrustedUnits ue)) - || unitIsTrusted (unsafeLookupUnit ue u) - +-- | Do we trust the 'UnitInfo' for the given 'UnitId'? isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool isUnitIdTrusted ue u = - Set.member u (trustedUnits ue) && (Set.notMember u (distrustedUnits ue)) + elementOfUniqSet u (trustedUnits ue) && (not $ elementOfUniqSet u (distrustedUnits ue)) || unitIsTrusted (unsafeLookupUnitId ue u) +-- | Do we trust the 'UnitInfo' for the given 'Unit'? +isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool +isUnitTrusted ue u = + isUnitIdTrusted ue (toUnitId u) + +-- | Do we trust the given 'UnitInfo'? isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool isUnitInfoTrusted ue unit_info = - Set.member (unitId unit_info) (trustedUnits ue) && (Set.notMember (unitId unit_info) (distrustedUnits ue)) - || unitIsTrusted unit_info + isUnitIdTrusted ue (unitId unit_info) -- ---------------------------------------------------------------------------- -- Loading the unit db files and building up the unit state @@ -714,22 +440,22 @@ isUnitInfoTrusted ue unit_info = -- command-line (@-package@, @-hide-package@ etc.) -- -- 'initUnits' can be called again subsequently after updating the --- 'packageFlags' field of the 'DynFlags', and it will update the --- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) +-- 'packageFlags' and 'packageDBFlags' fields of the 'DynFlags', and it will +-- update the 'unitState' in 'DynFlags'. +initUnits :: Logger -> DynFlags -> UnitIndexCache -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) initUnits logger dflags unit_index cached_dbs home_units = do let forceUnitInfoMap state = unitInfoMap state `seq` () unit_state <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger unit_index cached_dbs (initUnitConfig dflags home_units) putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - wireMap <- ui_wireMap <$> readIORef unit_index + wireMap <- wiringMap <$> readUnitIndex unit_index let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) @@ -756,7 +482,7 @@ initUnits logger dflags unit_index cached_dbs home_units = do return (unit_state,home_unit,mconstants) mkHomeUnit - :: WiringMap + :: WireMap -> UnitId -- ^ Home unit id -> Maybe UnitId -- ^ Home unit instance of -> [(ModuleName, Module)] -- ^ Home unit instantiations @@ -765,7 +491,7 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = let -- Some wired units can be used to instantiate the home unit. We need to -- replace their unit keys with their wired unit ids. - hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ + hu_instantiations = map (fmap (updateWiredInUnitIdInModule wmap)) hu_instantiations_ in case (hu_instanceof, hu_instantiations) of (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") @@ -782,205 +508,6 @@ mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = | otherwise -> DefiniteHomeUnit hu_id (Just (u, is)) --- ----------------------------------------------------------------------------- --- Reading the unit database(s) - -readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] -readUnitDatabases logger cfg = do - conf_refs <- getUnitDbRefs cfg - confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readOrGetUnitDatabase logger cfg) confs - - -getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] -getUnitDbRefs cfg = do - let system_conf_refs = [UserPkgDb, GlobalPkgDb] - - e_pkg_path <- tryIO (getEnv $ map toUpper (unitConfigProgramName cfg) ++ "_PACKAGE_PATH") - let base_conf_refs = case e_pkg_path of - Left _ -> system_conf_refs - Right path - | Just (xs, x) <- snocView path, isSearchPathSeparator x - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs - | otherwise - -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path)) - - -- Apply the package DB-related flags from the command line to get the - -- final list of package DBs. - -- - -- Notes on ordering: - -- * The list of flags is reversed (later ones first) - -- * We work with the package DB list in "left shadows right" order - -- * and finally reverse it at the end, to get "right shadows left" - -- - return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg)) - where - doFlag (PackageDB p) dbs = p : dbs - doFlag NoUserPackageDB dbs = filter isNotUser dbs - doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs - doFlag ClearPackageDBs _ = [] - - isNotUser UserPkgDb = False - isNotUser _ = True - - isNotGlobal GlobalPkgDb = False - isNotGlobal _ = True - --- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' --- when the user database filepath is expected but the latter doesn't exist. --- --- NB: This logic is reimplemented in Cabal, so if you change it, --- make sure you update Cabal. (Or, better yet, dump it in the --- compiler info so Cabal can use the info.) -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath) -resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg -resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do - dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg) - let pkgconf = dir </> unitConfigDBName cfg - exist <- tryMaybeT $ doesDirectoryExist pkgconf - if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero -resolveUnitDatabase _ (PkgDbPath name) = return $ Just name - --- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location. -readOrGetUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readOrGetUnitDatabase logger cfg conf_file = - readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case - Nothing -> do - new_db <- readUnitDatabase logger cfg conf_file - cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db - pure new_db - Just db -> - pure db - --- | Read the 'UnitDatabase' at the given location. -readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) -readUnitDatabase logger cfg conf_file = do - isdir <- OsPath.doesDirectoryExist conf_file - - proto_pkg_configs <- - if isdir - then readDirStyleUnitInfo conf_file - else do - isfile <- OsPath.doesFileExist conf_file - if isfile - then do - mpkgs <- tryReadOldFileStyleUnitInfo - case mpkgs of - Just pkgs -> return pkgs - Nothing -> throwGhcExceptionIO $ InstallationError $ - "ghc no longer supports single-file style package " ++ - "databases (" ++ show conf_file ++ - ") use 'ghc-pkg init' to create the database with " ++ - "the correct format." - else throwGhcExceptionIO $ InstallationError $ - "can't find a package database at " ++ show conf_file - - let - -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot - conf_file' = OsPath.dropTrailingPathSeparator conf_file - top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) - pkgroot = OsPath.takeDirectory conf_file' - pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) - proto_pkg_configs - -- - pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 - return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 - where - readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] - readDirStyleUnitInfo conf_dir = do - let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache") - cache_exists <- OsPath.doesFileExist filename - if cache_exists - then do - debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename - readPackageDbForGhc filename - else do - -- If there is no package.cache file, we check if the database is not - -- empty by inspecting if the directory contains any .conf file. If it - -- does, something is wrong and we fail. Otherwise we assume that the - -- database is empty. - debugTraceMsg logger 2 $ text "There is no package.cache in" - <+> ppr conf_dir - <> text ", checking if the database is empty" - db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf")) - <$> OsPath.getDirectoryContents conf_dir - if db_empty - then do - debugTraceMsg logger 3 $ text "There are no .conf files in" - <+> ppr conf_dir <> text ", treating" - <+> text "package database as empty" - return [] - else - throwGhcExceptionIO $ InstallationError $ - "there is no package.cache in " ++ show conf_dir ++ - " even though package database is not empty" - - - -- Single-file style package dbs have been deprecated for some time, but - -- it turns out that Cabal was using them in one place. So this is a - -- workaround to allow older Cabal versions to use this newer ghc. - -- We check if the file db contains just "[]" and if so, we look for a new - -- dir-style db in conf_file.d/, ie in a dir next to the given file. - -- We cannot just replace the file with a new dir style since Cabal still - -- assumes it's a file and tries to overwrite with 'writeFile'. - -- ghc-pkg also cooperates with this workaround. - tryReadOldFileStyleUnitInfo = do - content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return "" - if take 2 content == "[]" - then do - let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d" - direxists <- OsPath.doesDirectoryExist conf_dir - if direxists - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> ppr conf_dir) - liftM Just (readDirStyleUnitInfo conf_dir) - else return (Just []) -- ghc-pkg will create it when it's updated - else return Nothing - -mungeUnitInfo :: OsPath -> OsPath - -> UnitInfo -> UnitInfo -mungeUnitInfo top_dir pkgroot = - mungeBytecodeLibFields - . mungeLibDirFields - . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot)) - -mungeLibDirFields :: UnitInfo -> UnitInfo -mungeLibDirFields pkg = - pkg { - unitLibraryDynDirs = case unitLibraryDynDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - , unitLibraryDirsStatic = case unitLibraryDirsStatic pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - --- | Default to using library-dirs if bytecode library dirs is not explicitly set. -mungeBytecodeLibFields :: UnitInfo -> UnitInfo -mungeBytecodeLibFields pkg = - pkg { - unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of - [] -> unitLibraryDirs pkg - ds -> ds - } - -seqUnitInfo :: UnitInfo -> b -> b -seqUnitInfo ui b = - unitImportDirs ui `seqList` - unitIncludeDirs ui `seqList` - unitLibraryDirs ui `seqList` - unitLibraryBytecodeDirs ui `seqList` - unitExtDepFrameworkDirs ui `seq` - unitHaddockInterfaces ui `seq` - unitHaddockHTMLs ui `seqList` - unitLibraryDynDirs ui `seqList` - unitLibraryDirsStatic ui `seqList` - unitDepends ui `seqList` - unitExposedModules ui `seqList` - b - -evaluateUnitInfo :: UnitInfo -> IO UnitInfo -evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) - -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -989,9 +516,9 @@ applyTrustFlag :: UnitPrecedenceMap -> UnusableUnits -> [UnitInfo] - -> (Set.Set UnitId, Set.Set UnitId) + -> (UniqSet UnitId, UniqSet UnitId) -> TrustFlag - -> MaybeErr UnitErr (Set.Set UnitId, Set.Set UnitId) + -> MaybeErr UnitErr (UniqSet UnitId, UniqSet UnitId) applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag = case flag of -- we trust all matching packages. Maybe should only trust first one? @@ -1006,11 +533,11 @@ applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag = Left ps -> Failed (TrustFlagErr flag ps) Right (ps,_) -> Succeeded (removeAll ps trusted, insertAll ps distrusted) -insertAll :: [UnitInfo] -> Set UnitId -> Set UnitId -insertAll elements set = foldl' (\ acc -> flip Set.insert acc . unitId) set elements +insertAll :: [UnitInfo] -> UniqSet UnitId -> UniqSet UnitId +insertAll elements set = foldl' (\ acc -> addOneToUniqSet acc . unitId) set elements -removeAll :: [UnitInfo] -> Set UnitId -> Set UnitId -removeAll elements set = foldl' (\ acc -> flip Set.delete acc . unitId) set elements +removeAll :: [UnitInfo] -> UniqSet UnitId -> UniqSet UnitId +removeAll elements set = foldl' (\ acc -> addOneToUniqSet acc . unitId) set elements applyPackageFlag :: UnitPrecedenceMap @@ -1094,267 +621,8 @@ applyPackageFlag prec_map pkg_map unusable no_hide_others pkgs vm flag = Left ps -> Failed (PackageFlagErr flag ps) Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) --- | Like 'selectPackages', but doesn't return a list of unmatched --- packages. Furthermore, any packages it returns are *renamed* --- if the 'UnitArg' has a renaming associated with it. -findPackages :: UnitPrecedenceMap - -> UnitInfoMap - -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - [UnitInfo] -findPackages prec_map pkg_map arg pkgs unusable - = let ps = mapMaybe (finder arg) pkgs - in if null ps - then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps) - where - finder (PackageArg str) p - = if matchingStr str p - then Just p - else Nothing - finder (UnitIdArg uid) p - = case uid of - RealUnit (Definite iuid) - | iuid == unitId p - -> Just p - VirtUnit inst - | instUnitInstanceOf inst == unitId p - -> Just (renameUnitInfo pkg_map (instUnitInsts inst) p) - _ -> Nothing - -selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo] - -> UnusableUnits - -> Either [(UnitInfo, UnusableUnitReason)] - ([UnitInfo], [UnitInfo]) -selectPackages prec_map arg pkgs unusable - = let matches = matching arg - (ps,rest) = partition matches pkgs - in if null ps - then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) - else Right (sortByPreference prec_map ps, rest) - --- | Rename a 'UnitInfo' according to some module instantiation. -renameUnitInfo :: UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo -renameUnitInfo pkg_map insts conf = - let hsubst = listToUFM insts - smod = renameHoleModule' pkg_map hsubst - new_insts = map (\(k,v) -> (k,smod v)) (unitInstantiations conf) - in conf { - unitInstantiations = new_insts, - unitExposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) - (unitExposedModules conf) - } - - --- A package named on the command line can either include the --- version, or just the name if it is unambiguous. -matchingStr :: String -> UnitInfo -> Bool -matchingStr str p - = str == unitPackageIdString p - || str == unitPackageNameString p - -matchingId :: UnitId -> UnitInfo -> Bool -matchingId uid p = uid == unitId p - -matching :: PackageArg -> UnitInfo -> Bool -matching (PackageArg str) = matchingStr str -matching (UnitIdArg (RealUnit (Definite uid))) = matchingId uid -matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case - --- | This sorts a list of packages, putting "preferred" packages first. --- See 'compareByPreference' for the semantics of "preference". -sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo] -sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) - --- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking --- which should be "active". Here is the order of preference: --- --- 1. First, prefer the latest version --- 2. If the versions are the same, prefer the package that --- came in the latest package database. --- --- Pursuant to #12518, we could change this policy to, for example, remove --- the version preference, meaning that we would always prefer the units --- in later unit database. -compareByPreference - :: UnitPrecedenceMap - -> UnitInfo - -> UnitInfo - -> Ordering -compareByPreference prec_map pkg pkg' - = case comparing unitPackageVersion pkg pkg' of - GT -> GT - EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) - , Just prec' <- lookupUniqMap prec_map (unitId pkg') - -- Prefer the unit from the later DB flag (i.e., higher - -- precedence) - -> compare prec prec' - | otherwise - -> EQ - LT -> LT - -comparing :: Ord a => (t -> a) -> t -> t -> Ordering -comparing f a b = f a `compare` f b - -pprFlag :: PackageFlag -> SDoc -pprFlag flag = case flag of - HidePackage p -> text "-hide-package " <> text p - ExposePackage doc _ _ -> text doc - -pprTrustFlag :: TrustFlag -> SDoc -pprTrustFlag flag = case flag of - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - --- ----------------------------------------------------------------------------- --- Wired-in units --- --- See Note [Wired-in units] in GHC.Unit.Types - -type WiringMap = UniqMap UnitId UnitId -type UnwiringMap = UniqMap UnitId UnitId - -findWiredInUnits - :: Logger - -> UnitPrecedenceMap - -> [UnitInfo] -- database - -> VisibilityMap -- info on what units are visible - -- for wired in selection - -> IO WiringMap -- map from unit id to wired identity -findWiredInUnits logger prec_map pkgs vis_map = do - -- Now we must find our wired-in units, and rename them to - -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Types - let - matches :: UnitInfo -> UnitId -> Bool - pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) - - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. - -- - -- When choosing which package to map to a wired-in package - -- name, we try to pick the latest version of exposed packages. - -- However, if there are no exposed wired in packages available - -- (e.g. -hide-all-packages was used), we can't bail: we *have* - -- to assign a package for the wired-in package: so we try again - -- with hidden packages included to (and pick the latest - -- version). - -- - -- You can also override the default choice by using -ignore-package: - -- this works even when there is no exposed wired in package - -- available. - -- - findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] - where - all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] - - try ps = case sortByPreference prec_map ps of - p:_ -> Just <$> pick p - _ -> pure Nothing - - notfound = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " not found." - return Nothing - pick :: UnitInfo -> IO (UnitId, UnitInfo) - pick pkg = do - debugTraceMsg logger 2 $ - text "wired-in package " - <> ftext (unitIdFS wired_pkg) - <> text " mapped to " - <> ppr (unitId pkg) - return (wired_pkg, pkg) - - - mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds - let - wired_in_pkgs = catMaybes mb_wired_in_pkgs - - wiredInMap :: UniqMap UnitId UnitId - wiredInMap = listToUniqMap - [ (unitId realUnitInfo, wiredInUnitId) - | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs - , not (unitIsIndefinite realUnitInfo) - ] - - return wiredInMap - -updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] -updateWiredInUnits wiredInMap knownInfos pkgs = - map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs - -updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo -updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = - let - upd_wired_in_pkg wiredInUnitId pkg = - pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - in - case lookupUniqMap wiredInMap (unitId pkg) of - Just wiredIn -> - case lookupGlobalUnitInfoMap (GlobalUnitKey wiredIn (unitAbiHash pkg)) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps $ upd_wired_in_pkg wiredIn pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - Nothing -> case lookupGlobalUnitInfoMap (globalUnitKeyFromUnitInfo pkg) knownInfos of - Just ui -> - Right ui - Nothing -> - let - updated_pkg = upd_deps pkg - in - Left $ seqUnitInfo updated_pkg updated_pkg - --- Helper functions for rewiring Module and Unit. These --- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. --- --- For instance, base-4.9.0.0 will be rewritten to just base, to match --- what appears in GHC.Builtin.Names. - -upd_wired_in_mod :: WiringMap -> Module -> Module -upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m - -upd_wired_in_uid :: WiringMap -> Unit -> Unit -upd_wired_in_uid wiredInMap u = case u of - HoleUnit -> HoleUnit - RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid)) - VirtUnit indef_uid -> - VirtUnit $ mkInstantiatedUnit - (instUnitInstanceOf indef_uid) - (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (instUnitInsts indef_uid)) - -upd_wired_in :: WiringMap -> UnitId -> UnitId -upd_wired_in wiredInMap key - | Just key' <- lookupUniqMap wiredInMap key = key' - | otherwise = key - -updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap -updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) +updateVisibilityMap :: WireMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (listWireMap wiredInMap) where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of Nothing -> vm Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from))) @@ -1362,51 +630,6 @@ updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList w -- ---------------------------------------------------------------------------- --- | The reason why a unit is unusable. -data UnusableUnitReason - = -- | We ignored it explicitly using @-ignore-package@. - IgnoredWithFlag - -- | This unit transitively depends on a unit that was never present - -- in any of the provided databases. - | BrokenDependencies [UnitId] - -- | This unit transitively depends on a unit involved in a cycle. - -- Note that the list of 'UnitId' reports the direct dependencies - -- of this unit that (transitively) depended on the cycle, and not - -- the actual cycle itself (which we report separately at high verbosity.) - | CyclicDependencies [UnitId] - -- | This unit transitively depends on a unit which was ignored. - | IgnoredDependencies [UnitId] - -- | This unit transitively depends on a unit which was - -- shadowed by an ABI-incompatible unit. - | ShadowedDependencies [UnitId] - -instance Outputable UnusableUnitReason where - ppr IgnoredWithFlag = text "[ignored with flag]" - ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) - ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) - ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) - ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) - -type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) - -pprReason :: SDoc -> UnusableUnitReason -> SDoc -pprReason pref reason = case reason of - IgnoredWithFlag -> - pref <+> text "ignored due to an -ignore-package flag" - BrokenDependencies deps -> - pref <+> text "unusable due to missing dependencies:" $$ - nest 2 (hsep (map ppr deps)) - CyclicDependencies deps -> - pref <+> text "unusable due to cyclic dependencies:" $$ - nest 2 (hsep (map ppr deps)) - IgnoredDependencies deps -> - pref <+> text ("unusable because the -ignore-package flag was used to " ++ - "ignore at least one of its dependencies:") $$ - nest 2 (hsep (map ppr deps)) - ShadowedDependencies deps -> - pref <+> text "unusable due to shadowed dependencies:" $$ - nest 2 (hsep (map ppr deps)) - reportCycles :: Logger -> [SCC UnitInfo] -> IO () reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs where @@ -1416,193 +639,6 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs text "these packages are involved in a cycle:" $$ nest 2 (hsep (map (ppr . unitId) vs)) -reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = when (logVerbAtLeast logger 2) $ mapM_ report (nonDetUniqMapToList pkgs) - where - report (ipid, (_, reason)) = - debugTraceMsg logger 2 $ - pprReason - (text "package" <+> ppr ipid <+> text "is") reason - --- ---------------------------------------------------------------------------- --- --- Utilities on the database --- - --- | A reverse dependency index, mapping an 'UnitId' to --- the 'UnitId's which have a dependency on it. -type RevIndex = UniqMap UnitId [UnitId] - --- | Compute the reverse dependency index of a unit database. -reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db - where - go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex - go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = addToUniqMap_C (++) r to [from] - --- | Given a list of 'UnitId's to remove, a database, --- and a reverse dependency index (as computed by 'reverseDeps'), --- remove those units, plus any units which depend on them. --- Returns the pruned database, as well as a list of 'UnitInfo's --- that was removed. -removeUnits :: [UnitId] -> RevIndex - -> UnitInfoMap - -> (UnitInfoMap, [UnitInfo]) -removeUnits uids index m = go uids (m,[]) - where - go [] (m,pkgs) = (m,pkgs) - go (uid:uids) (m,pkgs) - | Just pkg <- lookupUniqMap m uid - = case lookupUniqMap index uid of - Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) - | otherwise - = go uids (m,pkgs) - --- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends' --- which correspond to units that do not exist in the index. -depsNotAvailable :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) - --- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in --- 'unitAbiDepends' which correspond to units that do not exist, OR have --- mismatching ABIs. -depsAbiMismatch :: UnitInfoMap - -> UnitInfo - -> [UnitId] -depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg - where - abiMatch (dep_uid, abi) - | Just dep_pkg <- lookupUniqMap pkg_map dep_uid - = unitAbiHash dep_pkg == abi - | otherwise - = False - --- ----------------------------------------------------------------------------- --- Ignore units - -ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) - where - doit (IgnorePackage str) = - case partition (matchingStr str) pkgs of - (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) - | p <- ps ] - -- missing unit is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. - --- ---------------------------------------------------------------------------- --- --- Merging databases --- - --- | For each unit, a mapping from uid -> i indicates that this --- unit was brought into GHC by the ith @-package-db@ flag on --- the command line. We use this mapping to make sure we prefer --- units that were defined later on the command line, if there --- is an ambiguity. -type UnitPrecedenceMap = UniqMap UnitId Int - --- | Given a list of databases, merge them together, where --- units with the same unit id in later databases override --- earlier ones. This does NOT check if the resulting database --- makes sense (that's done by 'validateDatabase'). -mergeDatabases :: Logger -> [UnitDatabase UnitId] - -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] - where - merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do - debugTraceMsg logger 2 $ - text "loading package database" <+> ppr db_path - when (logVerbAtLeast logger 2) $ - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" - return (pkg_map', prec_map') - where - db_map = mk_pkg_map db - mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) - - -- The set of UnitIds which appear in both db and pkgs. These are the - -- ones that get overridden. Compute this just to give some - -- helpful debug messages at -v2 - override_set :: Set UnitId - override_set = Set.intersection (nonDetUniqMapToKeySet db_map) - (nonDetUniqMapToKeySet pkg_map) - - -- Now merge the sets together (NB: in case of duplicate, - -- first argument preferred) - pkg_map' :: UnitInfoMap - pkg_map' = pkg_map `plusUniqMap` db_map - - prec_map' :: UnitPrecedenceMap - prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) - --- | Validates a database, removing unusable units from it --- (this includes removing units that the user has explicitly --- ignored.) Our general strategy: --- --- 1. Remove all broken units (dangling dependencies) --- 2. Remove all units that are cyclic --- 3. Apply ignore flags --- 4. Remove all units which have deps with mismatching ABIs --- -validateDatabase :: UnitConfig -> UnitInfoMap - -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo]) -validateDatabase cfg pkg_map1 = - (pkg_map5, unusable, sccs) - where - ignore_flags = reverse (unitConfigFlagsIgnored cfg) - - -- Compute the reverse dependency index - index = reverseDeps pkg_map1 - - -- Helper function - mk_unusable mk_err dep_matcher m uids = - listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids - ] - - -- Find broken units - directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (nonDetEltsUniqMap pkg_map1) - (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 - unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken - - -- Find recursive units - sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- nonDetEltsUniqMap pkg_map2 ] - getCyclicSCC (CyclicSCC vs) = map unitId vs - getCyclicSCC (AcyclicSCC _) = [] - (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 - unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic - - -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) - (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 - unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored - - -- Knock out units whose dependencies don't agree with ABI - -- (i.e., got invalidated due to shadowing) - directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (nonDetEltsUniqMap pkg_map4) - (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 - unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - - -- combine all unusables. The order is important for shadowing. - -- plusUniqMapList folds using plusUFM which is right biased (opposite of - -- Data.Map.union) so the head of the list should be the least preferred - unusable = plusUniqMapList [ unusable_shadowed - , unusable_cyclic - , unusable_broken - , unusable_ignored - , directly_ignored - ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1610,10 +646,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger - -> IORef UnitIndex + -> UnitIndexCache + -> ExternalUnitDatabaseCache UnitId -> UnitConfig -> IO UnitState -mkUnitState logger unit_index cfg = do +mkUnitState logger unit_index_cache db_cache cfg = do {- Plan. @@ -1667,17 +704,17 @@ mkUnitState logger unit_index cfg = do we build a mapping saying what every in scope module name points to. -} - raw_dbs <- readUnitDatabases logger cfg + raw_dbs <- readUnitDatabases logger db_cache (initUnitDbConfig cfg) -- distrust all units if the flag is set - let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) - allUnits = Set.unions $ map unitsOf raw_dbs + let unitsOf db = foldl' (\ acc ui -> addOneToUniqSet acc (unitId ui)) emptyUniqSet (unitDatabaseUnits db) + allUnits = unionManyUniqSets $ map unitsOf raw_dbs distrustedUnits | unitConfigDistrustAll cfg = allUnits - | otherwise = Set.empty + | otherwise = emptyUniqSet - trustedUnits = Set.empty + trustedUnits = emptyUniqSet dbs = raw_dbs @@ -1697,7 +734,7 @@ mkUnitState logger unit_index cfg = do -- Now that we've merged everything together, prune out unusable -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + let (pkg_map2, unusable, sccs) = validateDatabase (unitConfigFlagsIgnored cfg) pkg_map1 reportCycles logger sccs reportUnusable logger unusable @@ -1773,19 +810,19 @@ mkUnitState logger unit_index cfg = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - ui <- readIORef unit_index + ui <- readUnitIndex unit_index_cache (wired_map, pkgs2) <- do - wireMap <- if isWireMapEmpty ui + wireMap <- if not (wireMapExists ui) then do wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2 - modifyIORef' unit_index (setWireMap wmap) + modifyUnitIndexCache unit_index_cache (setWireMap wmap) pure wmap else do - pure $ ui_wireMap ui + pure $ wiringMap ui - let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + let all_pkgs = updateWiredInUnits wireMap (globalUnits ui) pkgs1 (new_pkgs, _pkgs_set) = partitionEithers all_pkgs - modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) + modifyUnitIndexCache unit_index_cache (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (wireMap, map (either id id) all_pkgs) let pkg_db = mkUnitInfoMap pkgs2 @@ -1859,7 +896,7 @@ mkUnitState logger unit_index cfg = do $ closeUnitDeps pkg_db $ zip (map toUnitId preload3) (repeat Nothing) - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db vis_map + let mod_map1 = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable mod_map = mod_map2 `plusUniqMap` mod_map1 @@ -1872,10 +909,8 @@ mkUnitState logger unit_index cfg = do , trustedUnits = trusted , distrustedUnits = distrusted , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map + , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger (unitConfigAllowVirtual cfg) pkg_db plugin_vis_map , packageNameMap = pkgname_map - -- , wireMap = wired_map - -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } @@ -1893,157 +928,15 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- MP: This does not yet support thinning/renaming go cur _ = cur - --- | Given a wired-in 'Unit', "unwire" it into the 'Unit' --- that it was recorded as in the package database. -unwireUnit :: UnitIndex -> Unit -> Unit -unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) -unwireUnit _ uid = uid - --- ----------------------------------------------------------------------------- --- | Makes the mapping from ModuleName to package info - --- Slight irritation: we proceed by leafing through everything --- in the installed package database, which makes handling indefinite --- packages a bit bothersome. - -mkModuleNameProvidersMap - :: Logger - -> UnitConfig - -> UnitInfoMap - -> VisibilityMap - -> ModuleNameProvidersMap -mkModuleNameProvidersMap logger cfg pkg_map vis_map = - -- What should we fold on? Both situations are awkward: - -- - -- * Folding on the visibility map means that we won't create - -- entries for packages that aren't mentioned in vis_map - -- (e.g., hidden packages, causing #14717) - -- - -- * Folding on pkg_map is awkward because if we have an - -- Backpack instantiation, we need to possibly add a - -- package from pkg_map multiple times to the actual - -- ModuleNameProvidersMap. Also, we don't really want - -- definite package instantiations to show up in the - -- list of possibilities. - -- - -- So what will we do instead? We'll extend vis_map with - -- entries for every definite (for non-Backpack) and - -- indefinite (for Backpack) package, so that we get the - -- hidden entries we need. - nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended - where - vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map - - default_vis = listToUniqMap - [ (mkUnit pkg, mempty) - | (_, pkg) <- nonDetUniqMapToList pkg_map - -- Exclude specific instantiations of an indefinite - -- package - , unitIsIndefinite pkg || null (unitInstantiations pkg) - ] - - emptyMap = emptyUniqMap - setOrigins m os = fmap (const os) m - extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap - = addListTo modmap theBindings - where - pkg = unit_lookup uid - - theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - theBindings = newBindings b rns - - newBindings :: Bool - -> [(ModuleName, ModuleName)] - -> [(ModuleName, UniqMap Module ModuleOrigin)] - newBindings e rns = es e ++ hiddens ++ map rnBinding rns - - rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, UniqMap Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) - where origEntry = case lookupUFM esmap orig of - Just r -> r - Nothing -> throwGhcException (CmdLineError (renderWithContext - (log_default_user_context (logFlags logger)) - (text "package flag: could not find module name" <+> - ppr orig <+> text "in package" <+> ppr pk))) - - es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] - es e = do - (m, exposedReexport) <- exposed_mods - let (pk', m', origin') = - case exposedReexport of - Nothing -> (pk, m, fromExposedModules e) - Just (Module pk' m') -> - (pk', m', fromReexportedModules e pkg) - return (m, mkModMap pk' m' origin') - - esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) - esmap = listToUFM (es False) -- parameter here doesn't matter, orig will - -- be overwritten - - hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] - - pk = mkUnit pkg - unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map uid - `orElse` pprPanic "unit_lookup" (ppr uid) - - exposed_mods = unitExposedModules pkg - hidden_mods = unitHiddenModules pkg - --- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. -mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap -mkUnusableModuleNameProvidersMap unusables = - nonDetFoldUniqMap extend_modmap emptyUniqMap unusables - where - extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings - where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] - bindings = exposed ++ hidden - - origin_reexport = ModUnusable (UnusableUnit unit reason True) - origin_normal = ModUnusable (UnusableUnit unit reason False) - unit = mkUnit unit_info - - exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] - - -- with re-exports, c:Foo can be reexported from two (or more) - -- unusable packages: - -- Foo -> a:Foo (unusable reason A) -> c:Foo - -- -> b:Foo (unusable reason B) -> c:Foo - -- - -- We must be careful to not record the following (#21097): - -- Foo -> c:Foo (unusable reason A) - -- -> c:Foo (unusable reason B) - -- But: - -- Foo -> a:Foo (unusable reason A) - -- -> b:Foo (unusable reason B) - -- - get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) - get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) - -- in the reexport case, we create a virtual module that doesn't - -- exist but we don't care as it's only used as a key in the map. - - exposed_mods = unitExposedModules unit_info - hidden_mods = unitHiddenModules unit_info - --- | Add a list of key/value pairs to a nested map. --- --- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks --- when reloading modules in GHCi (see #4029). This ensures that each --- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) - => UniqMap k1 (UniqMap k2 a) - -> [(k1, UniqMap k2 a)] - -> UniqMap k1 (UniqMap k2 a) -addListTo = foldl' merge - where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v - --- | Create a singleton module mapping -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin -mkModMap pkg mod = unitUniqMap (mkModule pkg mod) - +initUnitDbConfig :: UnitConfig -> UnitDbConfig +initUnitDbConfig uc = UnitDbConfig + { unitDbConfigFlagsDB = unitConfigFlagsDB uc + , unitDbConfigProgramName = unitConfigProgramName uc + , unitDbConfigDBName = unitConfigDBName uc + , unitDbConfigPlatformArchOS = unitConfigPlatformArchOS uc + , unitDbConfigGlobalDB = unitConfigGlobalDB uc + , unitDbConfigGHCDir = unitConfigGHCDir uc + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -2185,7 +1078,7 @@ lookupModuleWithSuggestions' pkgs mod_map name mb_pn suggestions = fuzzyLookup (moduleNameString name) all_mods all_mods :: [(String, ModuleSuggestion)] -- All modules - all_mods = sortBy (comparing fst) $ + all_mods = sortOn fst $ [ (moduleNameString m, suggestion) | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) @@ -2199,78 +1092,7 @@ listVisibleModuleNames state = map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) where visible (_, ms) = anyUniqMap originVisible ms --- | Takes a list of UnitIds (and their "parent" dependency, used for error --- messages), and returns the list with dependencies included, in reverse --- dependency order (a units appears before those it depends on). -closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps --- | Similar to closeUnitDeps but takes a list of already loaded units as an --- additional argument. -closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps - --- | Add a UnitId and those it depends on (recursively) to the given list of --- UnitIds if they are not already in it. Return a list in reverse dependency --- order (a unit appears before those it depends on). --- --- The UnitId is looked up in the given UnitInfoMap (to find its dependencies). --- It it's not found, the optional parent unit is used to return a more precise --- error message ("dependency of <PARENT>"). -add_unit :: UnitInfoMap - -> [UnitId] - -> UnitId - -> Maybe UnitId - -> MaybeErr UnitErr [UnitId] -add_unit pkg_map ps p mb_parent - | p `elem` ps = return ps -- Check if we've already added this unit - | otherwise = case lookupUnitId' pkg_map p of - Nothing -> Failed (CloseUnitErr p mb_parent) - Just info -> do - -- Add the unit's dependents also - ps' <- foldM add_unit_key ps (unitDepends info) - return (p : ps') - where - add_unit_key xs key - = add_unit pkg_map xs key (Just p) - -data UnitErr - = CloseUnitErr !UnitId !(Maybe UnitId) - | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)] - | TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)] - -mayThrowUnitErr :: MaybeErr UnitErr a -> IO a -mayThrowUnitErr = \case - Failed e -> throwGhcExceptionIO - $ CmdLineError - $ renderWithContext defaultSDocContext - $ withPprStyle defaultUserStyle - $ ppr e - Succeeded a -> return a - -instance Outputable UnitErr where - ppr = \case - CloseUnitErr p mb_parent - -> (text "unknown unit:" <+> ppr p) - <> case mb_parent of - Nothing -> Outputable.empty - Just parent -> space <> parens (text "dependency of" - <+> ftext (unitIdFS parent)) - PackageFlagErr flag reasons - -> flag_err (pprFlag flag) reasons - - TrustFlagErr flag reasons - -> flag_err (pprTrustFlag flag) reasons - where - flag_err flag_doc reasons = - text "cannot satisfy " - <> flag_doc - <> (if null reasons then Outputable.empty else text ": ") - $$ nest 4 (vcat (map ppr_reason reasons) $$ - text "(use -v for more information)") - - ppr_reason (p, reason) = - pprReason (ppr (unitId p) <+> text "is") reason -- | Return this list of requirement interfaces that need to be merged -- to form @mod_name@, or @[]@ if this is not a requirement. @@ -2328,37 +1150,23 @@ pprUnitsSimple ue = pprUnitsWith pprIPI ue t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i --- | Show the mapping of modules to where they come from. -pprModuleMap :: ModuleNameProvidersMap -> SDoc -pprModuleMap mod_map = - vcat (map pprLine (nonDetUniqMapToList mod_map)) - where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) - pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc - pprEntry m (m',o) - | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) - | otherwise = ppr m' <+> parens (ppr o) +-- | Print unit-ids with UnitInfo found in the given UnitState +pprWithUnitState :: UnitState -> SDoc -> SDoc +pprWithUnitState state = updSDocContext (\ctx -> ctx + { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) + }) + +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) fsPackageName :: UnitInfo -> FastString fsPackageName info = fs where PackageName fs = unitPackageName info --- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. -instUnitToUnit :: InstantiatedUnit -> Unit -instUnitToUnit iuid = - -- NB: suppose that we want to compare the instantiated - -- unit p[H=impl:H] against p+abcd (where p+abcd - -- happens to be the existing, installed version of - -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] - -- VirtUnit, they won't compare equal; only - -- after improvement will the equality hold. - VirtUnit iuid - - --- | Substitution on module variables, mapping module names to module --- identifiers. -type ShHoleSubst = ModuleNameEnv Module +-- ----------------------------------------------------------------------------- +-- Module renaming -- | Substitutes holes in a 'Module'. NOT suitable for being called -- directly on a 'nameModule', see Note [Representation of module/name variables]. @@ -2374,44 +1182,19 @@ renameHoleModule state = renameHoleModule' (unitInfoMap state) renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit renameHoleUnit state = renameHoleUnit' (unitInfoMap state) --- | Like 'renameHoleModule', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleModule' :: UnitInfoMap -> ShHoleSubst -> Module -> Module -renameHoleModule' pkg_map env m - | not (isHoleModule m) = - let uid = renameHoleUnit' pkg_map env (moduleUnit m) - in mkModule uid (moduleName m) - | Just m' <- lookupUFM env (moduleName m) = m' - -- NB m = <Blah>, that's what's in scope. - | otherwise = m - --- | Like 'renameHoleUnit', but requires only 'UnitInfoMap' --- so it can be used by "GHC.Unit.State". -renameHoleUnit' :: UnitInfoMap -> ShHoleSubst -> Unit -> Unit -renameHoleUnit' pkg_map env uid = - case uid of - (VirtUnit - InstantiatedUnit{ instUnitInstanceOf = cid - , instUnitInsts = insts - , instUnitHoles = fh }) - -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) - then uid - else mkVirtUnit cid - (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) - _ -> uid - -- | Injects an 'InstantiatedModule' to 'Module' (see also -- 'instUnitToUnit'. instModuleToModule :: InstantiatedModule -> Module instModuleToModule (Module iuid mod_name) = mkModule (instUnitToUnit iuid) mod_name --- | Print unit-ids with UnitInfo found in the given UnitState -pprWithUnitState :: UnitState -> SDoc -> SDoc -pprWithUnitState state = updSDocContext (\ctx -> ctx - { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) - }) - --- | Print raw unit-ids, without removing the hash -pprRawUnitIds :: SDoc -> SDoc -pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) +-- | Return a `UnitId` which either wraps the `InstantiatedUnit` unchanged. +instUnitToUnit :: InstantiatedUnit -> Unit +instUnitToUnit iuid = + -- NB: suppose that we want to compare the instantiated + -- unit p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- VirtUnit, they won't compare equal; only + -- after improvement will the equality hold. + VirtUnit iuid ===================================== compiler/GHC/Unit/State.hs-boot ===================================== @@ -1,6 +1,3 @@ module GHC.Unit.State where data UnitState -data ModuleSuggestion -data ModuleOrigin -data UnusableUnit ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -578,7 +578,7 @@ had used @-ignore-package@). The affected packages are compiled with, e.g., @-this-unit-id base@, so that the symbols in the object files have the unversioned unit id in their name. -Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. +Make sure you change 'wiredInUnitIds' if you add an entry here. -} @@ -655,7 +655,7 @@ be it either hadrian or cabal, knows exactly the unit-id it passed with -this-un Note that we also ensure the ghc's unit key matches its unit id, both when hadrian or cabal is building ghc. This way, we no longer need to add `ghc` to -the WiringMap, and that's why 'wiredInUnitIds' no longer includes +the WireMap, and that's why 'wiredInUnitIds' no longer includes 'thisGhcUnitId'. -} ===================================== compiler/ghc.cabal.in ===================================== @@ -968,6 +968,14 @@ Library GHC.Unit.Env GHC.Unit.External GHC.Unit.External.Database + GHC.Unit.External.Index + GHC.Unit.External.ModuleOrigin + GHC.Unit.External.Providers + GHC.Unit.External.Query + GHC.Unit.External.Substitution + GHC.Unit.External.Validate + GHC.Unit.External.Visibility + GHC.Unit.External.Wired GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== ghc/GHCi/UI.hs ===================================== @@ -855,7 +855,7 @@ installInteractiveHomeUnits dflags = do setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do env <- GHC.getSession - let unit_index = hsc_unit_index env + let unit_index = hscUIC env (unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -547,7 +547,7 @@ generateConfigHs = do -- See Note [GHC's Unit Id] in GHC.Unit.Types -- -- It's crucial that the unit-id matches the unit-key -- ghc is no longer - -- part of the WiringMap, so we don't to go back and forth between the + -- part of the WireMap, so we don't to go back and forth between the -- unit-id and the unit-key -- we take care that they are the same by using -- 'pkgUnitId' on 'compiler' (the ghc-library package) to create the -- unit-id in both situations. ===================================== testsuite/tests/count-deps/CountDepsParser.stdout ===================================== @@ -227,6 +227,15 @@ GHC.Types.Var.Env GHC.Types.Var.FV GHC.Types.Var.Set GHC.Unit +GHC.Unit.External.Database +GHC.Unit.External.Index +GHC.Unit.External.ModuleOrigin +GHC.Unit.External.Providers +GHC.Unit.External.Query +GHC.Unit.External.Substitution +GHC.Unit.External.Validate +GHC.Unit.External.Visibility +GHC.Unit.External.Wired GHC.Unit.Home GHC.Unit.Info GHC.Unit.Module ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -69,6 +69,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Types.Name.Cache import GHC.Unit +import GHC.Unit.External.Index import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba143db3fc92bcc1abcbde08d427fc4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ba143db3fc92bcc1abcbde08d427fc4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/dcoutts/issue-27284
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed new branch wip/dcoutts/issue-27284 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/issue-27284 You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/dcoutts/capability-yield] 19 commits: ci: add missing docker permission workaround in abi-test job
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/capability-yield at Glasgow Haskell Compiler / GHC Commits: 0f64f348 by Cheng Shao at 2026-07-16T15:41:08+00:00 ci: add missing docker permission workaround in abi-test job - - - - - 660cb239 by Cheng Shao at 2026-07-16T19:37:48+00:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 08130257 by Cheng Shao at 2026-07-16T19:37:48+00:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00 Mark various language extension flags as deprecated (see #27329) The following language extensions are now deprecated: - AlternativeLayoutRule - AlternativeLayoutRuleTransitional - ParallelArrays - PolymorphicComponents - Rank2Types In addition, the warning `-Walternative-layout-rule-transitional` has been marked as deprecated, as it is emitted only under the deprecated extension `XAlternativeLayoutRuleTransitional`. - - - - - fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00 base: re-export GHC.Environment.getFullArgs from System.Environment CLC proposal https://github.com/haskell/core-libraries-committee/issues/431 - - - - - f46cc936 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Minor doc & comment improvements to releaseCapability_ - - - - - bea022e6 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Remove redundant USED_IF_THREADS attribute on Capability utilities - - - - - 71d4315e by Duncan Coutts at 2026-07-17T10:46:29+01:00 Move several Capability utils from Schedule.{c,h} to Capability.{c,h} They probably should have been there all along. This means all the pending_sync functionality is within Capability.{c,h}. We only expose pending_sync for the purpose of inline header functions. - - - - - 5660f38f by Duncan Coutts at 2026-07-17T10:46:29+01:00 Shuffle the pending sync type declarations for better readability Move them together into the section with the related functions that use them. Also drop the legacy use of the C 'volatile' modifier on the pending_sync variable. We use C atomics for such access, not volatile. - - - - - 553ec645 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Rename returning task queue helpers Follows a naming convention elsewhere. It also gives us suitable names to distinguish appending vs prepending to the queue, and we're about to add a prepend operation. - - - - - 3985384a by Duncan Coutts at 2026-07-17T10:46:29+01:00 Add a prepend operation for the returning task queue With a pending sync (e.g. for GC), we really want to be able to prioritise the task waiting on the sync over all other returning tasks. To do that we will need to prepend to the queue rather than append. - - - - - e3a6052d by Duncan Coutts at 2026-07-17T10:46:29+01:00 Introduce waitForCapability_ with additional priority arg Split waitForCapability into a wrapper with the existing type (since it is exported via the RTS API) and a worker with an extra argument. The new high_priority argument controls whether the task is appended or prepended to the returing task queue. The default, used by the waitForCapability wrapper, is false, meaning append to the end of the queue. This gives fairness. - - - - - 3fe6de57 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Make acquireAllCapabilities use high_priority on waitForCapability_ As discussed in issue #27473, a sync of all capabilities is something that needs to happen promptly (but often doesn't). One source of delay is that acquireAllCapabilities using waitForCapability would put the task trying to acquire each capability at the _end_ of the returning task queue. This gave every other returing task a full timeslice to run. Meanwhile, several other capabilities are blocked waiting for the sync to complete, leading to a loss of throughput. We use the new high_priority arg to waitForCapability_ to ensure that the requesting task is put on the front of the returing task queue. This will ensure that releaseCapability_ will prioritise giving the capability to the task requesting the sync. - - - - - 2d2c6fc3 by Duncan Coutts at 2026-07-17T10:46:29+01:00 In releaseCapability_ make the pending_sync case self-contained Previously the pending_sync case had to be checked _after_ the returning tasks case, since one of the possibilities (indeed the more likely possibility) is that the task calling waitForCapability will have enqueued itself as a returning task. Now we make the pending_sync case self-contained. We note in a comment the two possibilities: either the task calling waitForCapability has enqueued itself already and is waiting, or it's not got there yet. We can handle the first case by giving the capability to the task at the head of the returning tasks queue, and the second case by leaving the capability free. Another way to look at this, is that we move a special case of handling of the returning task case into the pending_sync case. That special case being a returing task during a pending sync. This makes the order of handling returning tasks vs pending sync independent. This is good, because really they're in the wrong priority order and we want to flip them around. - - - - - 546ff30f by Duncan Coutts at 2026-07-17T10:46:29+01:00 In releaseCapability_ prioritise pending sync over returning tasks Fixes issue #27460 As explained in the issue, a pending sync (e.g. for GC) should be dealt with promptly. Returning tasks are a lower priority. Historically however we had to check returning tasks first, because the synchronisation mechanism mixed up the task doing a sync with the tasks returning from safe FFI calls. The task performing the sync was very likely to be queued on the returning task list (and historically it was at the _end_ of this list!). We have now arranged that the task performing the sync is at the front of the returning task list, and in the pending sync case we now check the returning task list and run the first task from there if it there is one. This is by no means perfect, but it is better. See issue #27473 for a more general issue of cleaning up the design of the pending sync. - - - - - 0d2157a4 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Extend releaseCapability_ with an extra wakeup_worker modifier Document within releaseCapability_ the basic approach of looking for a series of conditions in priority order and acting on them. Explain the existing modifier within that understanding. Then add a new modifier, wakeup_worker and explain it in similar terms. What it does is skip two of the conditions in the priority list, with the effect that we prioritise waking up a worker task over a returning task or bound task. This feature is not yet used in this commit, but it will be used as part of a scheme to allow in-RTS I/O managers in the threaded RTS. This scheme will make use of being able to start a background worker thread, and that will use this feature to start it promptly. Also correct the yieldCapability docs to cover all the conditions, and in priority order for consistency. - - - - - 48e82bd1 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Move enqueueWorker next to where it is used. It's not general purpose at all. It's very specifically crafted to work with it's only caller: yieldCapability. It does very suprising things like releaseCapability_, release locks and terminate threads. This logic would be much clearer if done within yieldCapability. - - - - - 0c630f94 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Move code out of enqueueWorker and into releaseCapability_ Instead of directly releasing locks and terminating tasks, have it return whether the enqueue was successful or not. In the latter case, releaseCapability_ itself will release locks and terminate the task. This makes the logic of releaseCapability_ a lot clearer. Fiddling with tasks is what releaseCapability_ does, so it's better not to try and encapsulate this within a helper function. - - - - - 125e5f10 by Duncan Coutts at 2026-07-17T10:46:29+01:00 Clarify the logic and control flow in yieldCapability yieldCapability is unfortunately a bit complicated. This change restructures things slightly but should keep the behaviour the same. Previously after calling releaseCapability_ we had a bunch of alternatives, where in each branch we would use RELEASE_LOCK(cap->lock) and do various things before/after the lock is released. This was a bit hard to follow, or to extend (which we need to do). So now we have unconditional acquire and release of the cap->lock, so it's clear where that happens, with releaseCapability_ in between. Then in between these steps we have the various other pre/post actions. Some before releaseCapability_, some after while holing the lock, and some after having released the lock. We explain this structure in a longer comment, and refer back to the structure from the code. - - - - - 64 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - + changelog.d/T27329 - + changelog.d/fix-make-install-j - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Types/Rank.hs - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/static_pointers.rst - hadrian/bindist/Makefile - libraries/base/changelog.md - libraries/base/src/System/Environment.hs - libraries/ghc-internal/ghc-internal.cabal.in - rts/Capability.c - rts/Capability.h - rts/Messages.c - rts/RtsAPI.c - rts/Schedule.c - rts/Schedule.h - testsuite/tests/backpack/should_compile/T13149.bkp - testsuite/tests/determinism/determ017/A.hs - testsuite/tests/ghci/scripts/T12005.script - testsuite/tests/haddock/perf/Fold.hs - testsuite/tests/indexed-types/should_fail/T7354.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/layout/layout001.stdout - testsuite/tests/layout/layout002.stdout - testsuite/tests/layout/layout003.stdout - testsuite/tests/layout/layout004.stdout - testsuite/tests/layout/layout005.stdout - testsuite/tests/layout/layout006.stdout - testsuite/tests/layout/layout007.stdout - testsuite/tests/layout/layout008.stdout - testsuite/tests/layout/layout009.stdout - testsuite/tests/linear/should_compile/T1735Min.hs - + testsuite/tests/parser/should_compile/T13087.stderr - testsuite/tests/parser/should_fail/T8431.stderr - testsuite/tests/parser/should_fail/readFail038.stderr - testsuite/tests/perf/compiler/T3064.hs - testsuite/tests/polykinds/T7594.hs - testsuite/tests/programs/thurston-modular-arith/Main.hs - testsuite/tests/rts/ipe/IpeStats/Fold.hs - testsuite/tests/simplCore/should_compile/T11562.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs - testsuite/tests/typecheck/should_compile/T12507.hs - testsuite/tests/typecheck/should_compile/T13951.hs - testsuite/tests/typecheck/should_compile/T18920.hs - testsuite/tests/typecheck/should_compile/T2595.hs - testsuite/tests/typecheck/should_compile/T7541.hs - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7368a.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731-short.hs - testsuite/tests/typecheck/should_run/T3731.hs - testsuite/tests/typecheck/should_run/church.hs - testsuite/tests/typecheck/should_run/tcrun008.hs - testsuite/tests/typecheck/should_run/tcrun017.hs - testsuite/tests/typecheck/should_run/tcrun026.hs - testsuite/tests/typecheck/should_run/tcrun035.hs - testsuite/tests/typecheck/should_run/tcrun036.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f92cb93118b92a61fe7be82bd14cb9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f92cb93118b92a61fe7be82bd14cb9… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] 24 commits: ci: add missing docker permission workaround in abi-test job
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC Commits: 0f64f348 by Cheng Shao at 2026-07-16T15:41:08+00:00 ci: add missing docker permission workaround in abi-test job - - - - - 660cb239 by Cheng Shao at 2026-07-16T19:37:48+00:00 bindist: Fix make install -j race condition on macos/freebsd This patch fixes make install -j race condition on macos/freebsd. BSD install fails with EEXIST when multiple install processes concurrently create the same prefix directory. So we add an `install_dirs` prerequisite job that sequentially creates the directories for subsequent jobs to work with. Fixes #27499. Co-authored-by: Codex <codex(a)openai.com> - - - - - 08130257 by Cheng Shao at 2026-07-16T19:37:48+00:00 ci: run bindist make install with -j This patch makes the ci scripts run `make install` with `-j` to reduce wall clock time when installing the bindist, see related issue for benchmark numbers. This only affects ghc ci logic, the user-facing default is up to distributors and is still `-j1`. Closes #27029. - - - - - d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00 Mark various language extension flags as deprecated (see #27329) The following language extensions are now deprecated: - AlternativeLayoutRule - AlternativeLayoutRuleTransitional - ParallelArrays - PolymorphicComponents - Rank2Types In addition, the warning `-Walternative-layout-rule-transitional` has been marked as deprecated, as it is emitted only under the deprecated extension `XAlternativeLayoutRuleTransitional`. - - - - - fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00 base: re-export GHC.Environment.getFullArgs from System.Environment CLC proposal https://github.com/haskell/core-libraries-committee/issues/431 - - - - - bb368efa by Duncan Coutts at 2026-07-17T10:43:19+01:00 Move THREADED_RTS-conditional struct members to end of Capability Accessing members of the Capability struct from CMM code rely on accessor macros. (The macros are generated by deriveConstants). These macros have a single definition. This means that the offsets of all struct members must *not* vary based on THREADED_RTS vs !THREADED_RTS. This requires that any struct members that are conditional on THREADED_RTS must occur after the unconditional struct members. Hence we move all the ones that are conditional on THREADED_RTS to the end. Add a deriveConstants entry for the iomgr member of the Capability struct, which was the motivation for this change. Add warning messages to help our future selves. Debugging this took me a couple hours in gdb! - - - - - 35c97fb0 by Duncan Coutts at 2026-07-17T10:43:19+01: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()). - - - - - 4a89aee4 by Duncan Coutts at 2026-07-17T10:43:19+01: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. - - - - - 3c4536c9 by Duncan Coutts at 2026-07-17T10:43:19+01: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. - - - - - 1e02b5a8 by Duncan Coutts at 2026-07-17T10:43:19+01: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. - - - - - 27e0aa4f by Duncan Coutts at 2026-07-17T10:43:19+01:00 Free per-cap I/O managers during shutdown and forkProcess Historically this was not strictly necessary. The select and win32 legacy I/O managers did not maintain any dynamically allocated resources. The new poll one does (an auxillary table), and so this should be freed. After forkProcess, all threads get deleted. This includes threads waiting on I/O or timers. So as of this patch, resetting the I/O manager is just about tidying things up. For example, for the poll I/O manager this will reset the size of the AIOP table (which otherwise grows but never shrinks). In future however the re-initialising will become neeecessary for functionality, since some I/O managers will need to re-initialise wakeup fds that are set CLOEXEC. - - - - - 4a70715e by Duncan Coutts at 2026-07-17T10:43:19+01: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. - - - - - 36232b96 by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add a FIXME note in the Poll I/O manager - - - - - 9e17d6f5 by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add missing updateRemembSetPushClosure in poll I/O manager For the non-moving GC. - - - - - acd2b67c by Duncan Coutts at 2026-07-17T10:43:19+01:00 Minor doc improvement to struct StgAsyncIOOp member outcome Mention the enumeration names, as well as their numeric values. The rest of the code uses the enum names. - - - - - 0cc3a3f0 by Duncan Coutts at 2026-07-17T10:43:19+01:00 Minor doc improvements for StgTSOBlockInfo Clarify that certain union members are used only by certain legacy I/O managers. Hopefully we will be able to remove these at some point. - - - - - f912bc5b by Duncan Coutts at 2026-07-17T10:43:19+01:00 Avoid exporting various win32-specific rts symbols The BeginPrivate.h / EndPrivate.h scheme works perfectly well on Windows, but all of the rts/win32/*.h files were not using it. - - - - - a6b000ba by Duncan Coutts at 2026-07-17T10:43:19+01:00 Remove wakeupIOManager, ioManagerWakeup and setIOManagerWakeupFd We no longer need wakeupIOManager for the threaded RTS case, so we can remove it and the bits only needed to support it. This includes the pipe/eventfd fd shared between the RTS and the in-library I/O manager used for waking up the I/O manager thread. The pipe/eventfd still exists, but it no longer has to be communicated to the RTS, since the RTS no longer needs to use it. So we remove the RTS API export setIOManagerWakeupFd, and remove uses of it within the I/O managers in ghc-internal. - - - - - 737d71cc by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add a new interruptIOManager API for the I/O managers It will be used to interrupt awaitCompletedTimeoutsOrIO. Also update the return type and docs for awaitCompletedTimeoutsOrIO to have it return false when it gets interrupted, and have no useful post condition in that case. - - - - - 0f2fb3fd by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add interruptIOManager support for select I/O manager Uses the FdWakup mechanism. - - - - - f7e46e9c by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add interruptIOManager support for poll I/O manager Uses the FdWakup mechanism. A quirk we have to cope with is that we now need to poll one more fd -- the wakeup_fd_r -- but this fd has no corresponding entry in the aiop_table. This is awkward since we have set up our aiop_poll_table to be an auxilliary table with matching indicies. The solution this patch uses (and described in the comments) is to have two tables: struct pollfd *aiop_poll_table, *full_poll_table; and to have the aiop_poll_table alias the tail of the full_poll_table. The head entry in the full_poll_table is the extra fd. So we poll the full_poll_table, while the aiop_poll_table still has matching indicies with the aiop_table. Hurrah for C aliasing rules. - - - - - 81f5bc3a by Duncan Coutts at 2026-07-17T10:43:19+01:00 Add interruptIOManager support for win32 legacy I/O manager And remove unused related helper resetAbandonRequestWait. It is not called because the event is created in auto-reset mode, so never needs to be reset manually. - - - - - a357b29b by Duncan Coutts at 2026-07-17T10:43:19+01:00 Note lack of interruptIOManager support for WinIO I/O manager Though there's a plausible design, we can't sanely test it at the moment due to related WinIO bugs. Filed as issue #27403. - - - - - 04703995 by Duncan Coutts at 2026-07-17T10:43:19+01:00 Be more explicit about enum IOReadOrWrite values, and type within cmm Belt and braces. - - - - - 98 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - + changelog.d/T27329 - + changelog.d/fix-make-install-j - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Types/Rank.hs - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/static_pointers.rst - hadrian/bindist/Makefile - libraries/base/changelog.md - libraries/base/src/System/Environment.hs - libraries/ghc-internal/ghc-internal.cabal.in - libraries/ghc-internal/src/GHC/Internal/Event/Control.hs - libraries/ghc-internal/src/GHC/Internal/Event/Manager.hs - libraries/ghc-internal/src/GHC/Internal/Event/TimerManager.hs - rts/Capability.c - rts/Capability.h - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/RtsStartup.c - rts/RtsSymbols.c - rts/Schedule.c - rts/Schedule.h - rts/include/rts/IOInterface.h - rts/include/rts/storage/Closures.h - rts/include/rts/storage/TSO.h - rts/posix/FdWakeup.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 - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - rts/win32/AsyncWinIO.h - rts/win32/AwaitEvent.c - rts/win32/AwaitEvent.h - rts/win32/ConsoleHandler.h - rts/win32/MIOManager.h - rts/win32/ThrIOManager.h - rts/win32/WorkQueue.h - rts/win32/veh_excn.h - testsuite/tests/backpack/should_compile/T13149.bkp - testsuite/tests/determinism/determ017/A.hs - testsuite/tests/ghci/scripts/T12005.script - testsuite/tests/haddock/perf/Fold.hs - testsuite/tests/indexed-types/should_fail/T7354.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/layout/layout001.stdout - testsuite/tests/layout/layout002.stdout - testsuite/tests/layout/layout003.stdout - testsuite/tests/layout/layout004.stdout - testsuite/tests/layout/layout005.stdout - testsuite/tests/layout/layout006.stdout - testsuite/tests/layout/layout007.stdout - testsuite/tests/layout/layout008.stdout - testsuite/tests/layout/layout009.stdout - testsuite/tests/linear/should_compile/T1735Min.hs - + testsuite/tests/parser/should_compile/T13087.stderr - testsuite/tests/parser/should_fail/T8431.stderr - testsuite/tests/parser/should_fail/readFail038.stderr - testsuite/tests/perf/compiler/T3064.hs - testsuite/tests/polykinds/T7594.hs - testsuite/tests/programs/thurston-modular-arith/Main.hs - testsuite/tests/rts/ipe/IpeStats/Fold.hs - testsuite/tests/simplCore/should_compile/T11562.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs - testsuite/tests/typecheck/should_compile/T12507.hs - testsuite/tests/typecheck/should_compile/T13951.hs - testsuite/tests/typecheck/should_compile/T18920.hs - testsuite/tests/typecheck/should_compile/T2595.hs - testsuite/tests/typecheck/should_compile/T7541.hs - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7368a.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731-short.hs - testsuite/tests/typecheck/should_run/T3731.hs - testsuite/tests/typecheck/should_run/church.hs - testsuite/tests/typecheck/should_run/tcrun008.hs - testsuite/tests/typecheck/should_run/tcrun017.hs - testsuite/tests/typecheck/should_run/tcrun026.hs - testsuite/tests/typecheck/should_run/tcrun035.hs - testsuite/tests/typecheck/should_run/tcrun036.hs - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21d79c6796046355b097d34e94ea5b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/21d79c6796046355b097d34e94ea5b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/dcoutts/io-manager-tidy] 5 commits: Add interruptIOManager support for select I/O manager
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed to branch wip/dcoutts/io-manager-tidy at Glasgow Haskell Compiler / GHC Commits: c87c4aaa by Duncan Coutts at 2026-07-17T10:41:43+01:00 Add interruptIOManager support for select I/O manager Uses the FdWakup mechanism. - - - - - c26396b8 by Duncan Coutts at 2026-07-17T10:41:43+01:00 Add interruptIOManager support for poll I/O manager Uses the FdWakup mechanism. A quirk we have to cope with is that we now need to poll one more fd -- the wakeup_fd_r -- but this fd has no corresponding entry in the aiop_table. This is awkward since we have set up our aiop_poll_table to be an auxilliary table with matching indicies. The solution this patch uses (and described in the comments) is to have two tables: struct pollfd *aiop_poll_table, *full_poll_table; and to have the aiop_poll_table alias the tail of the full_poll_table. The head entry in the full_poll_table is the extra fd. So we poll the full_poll_table, while the aiop_poll_table still has matching indicies with the aiop_table. Hurrah for C aliasing rules. - - - - - ad977d5e by Duncan Coutts at 2026-07-17T10:41:43+01:00 Add interruptIOManager support for win32 legacy I/O manager And remove unused related helper resetAbandonRequestWait. It is not called because the event is created in auto-reset mode, so never needs to be reset manually. - - - - - e632ccfb by Duncan Coutts at 2026-07-17T10:41:43+01:00 Note lack of interruptIOManager support for WinIO I/O manager Though there's a plausible design, we can't sanely test it at the moment due to related WinIO bugs. Filed as issue #27403. - - - - - 21d79c67 by Duncan Coutts at 2026-07-17T10:41:43+01:00 Be more explicit about enum IOReadOrWrite values, and type within cmm Belt and braces. - - - - - 13 changed files: - rts/IOManager.c - rts/IOManager.h - rts/IOManagerInternals.h - rts/PrimOps.cmm - rts/posix/FdWakeup.h - rts/posix/Poll.c - rts/posix/Poll.h - rts/posix/Select.c - rts/posix/Select.h - rts/win32/AsyncMIO.c - rts/win32/AsyncMIO.h - rts/win32/AwaitEvent.c - rts/win32/AwaitEvent.h Changes: ===================================== rts/IOManager.c ===================================== @@ -343,9 +343,7 @@ void initCapabilityIOManager(CapIOManager *iomgr) switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - iomgr->blocked_queue_hd = END_TSO_QUEUE; - iomgr->blocked_queue_tl = END_TSO_QUEUE; - iomgr->sleeping_queue = END_TSO_QUEUE; + initCapabilityIOManagerSelect(iomgr); break; #endif @@ -376,6 +374,12 @@ void initCapabilityIOManager(CapIOManager *iomgr) void freeCapabilityIOManager(CapIOManager *iomgr) { switch (iomgr_type) { +#if defined(IOMGR_ENABLED_SELECT) + case IO_MANAGER_SELECT: + freeCapabilityIOManagerSelect(iomgr); + break; +#endif + #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: freeCapabilityIOManagerPoll(iomgr); @@ -735,13 +739,13 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr) switch (iomgr_type) { #if defined(IOMGR_ENABLED_SELECT) case IO_MANAGER_SELECT: - awaitCompletedTimeoutsOrIOSelect(iomgr, true); + completed = awaitCompletedTimeoutsOrIOSelect(iomgr, true); break; #endif #if defined(IOMGR_ENABLED_POLL) case IO_MANAGER_POLL: - awaitCompletedTimeoutsOrIOPoll(iomgr); + completed = awaitCompletedTimeoutsOrIOPoll(iomgr); break; #endif @@ -753,7 +757,7 @@ bool awaitCompletedTimeoutsOrIO(CapIOManager *iomgr) #if defined(IOMGR_ENABLED_WINIO) case IO_MANAGER_WINIO: #endif - awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true); + completed = awaitCompletedTimeoutsOrIOWin32(iomgr->cap, true); break; #endif default: @@ -774,6 +778,32 @@ void interruptIOManager(CapIOManager *iomgr) debugTrace(DEBUG_iomanager, "Interrupting the I/O manager..."); switch (iomgr_type) { +#if defined(IOMGR_ENABLED_SELECT) + case IO_MANAGER_SELECT: + interruptIOManagerSelect(iomgr); + break; +#endif + +#if defined(IOMGR_ENABLED_POLL) + case IO_MANAGER_POLL: + interruptIOManagerPoll(iomgr); + break; +#endif + +#if defined(IOMGR_ENABLED_WIN32_LEGACY) + case IO_MANAGER_WIN32_LEGACY: + abandonRequestWait(); + break; +#endif + +#if defined(IOMGR_ENABLED_WINIO) + case IO_MANAGER_WINIO: + /* FIXME: no support yet for interrupting in WinIO I/O manager + * See issue #27403 + */ + break; +#endif + default: break; } ===================================== rts/IOManager.h ===================================== @@ -319,7 +319,7 @@ void scavengeTSOIOManager(StgTSO *tso); /* Several code paths are almost identical between read and write paths. In * such cases we use a shared code path with an enum to say which we're doing. */ -typedef enum { IORead, IOWrite } IOReadOrWrite; +typedef enum { IORead = 0, IOWrite = 1 } IOReadOrWrite; /* Synchronous operations: I/O and delays. As synchronous operations they * necessarily operate on threads. The thread is suspended until the operation ===================================== rts/IOManagerInternals.h ===================================== @@ -46,6 +46,13 @@ struct _CapIOManager { StgTSO *sleeping_queue; #endif +#if defined(IOMGR_ENABLED_SELECT) || defined(IOMGR_ENABLED_POLL) +#if defined(HAVE_PREEMPTION) + /* FDs for waking up the I/O manager when it is blocked waiting */ + int interrupt_fd_r, interrupt_fd_w; +#endif +#endif + #if defined(IOMGR_ENABLED_POLL) /* AIOP and timeout collections shared by several I/O manager impls */ ClosureTable aiop_table; @@ -53,8 +60,11 @@ struct _CapIOManager { #endif #if defined(IOMGR_ENABLED_POLL) - /* Auxiliary table with size and indexes matching the aiop_table */ - struct pollfd *aiop_poll_table; + /* Auxiliary table with size and indexes matching the aiop_table. This is + * aliased to the tail of the full poll table, which has a head entry for + * the wakeup_fd_r above, so we can also poll that fd. + */ + struct pollfd *aiop_poll_table, *full_poll_table; #endif #if defined(IOMGR_ENABLED_WIN32_LEGACY) ===================================== rts/PrimOps.cmm ===================================== @@ -2269,7 +2269,7 @@ stg_waitReadzh ( W_ fd ) (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr", CurrentTSO "ptr", - /* IORead */ 0::I32, fd); + /* IORead */ 0::CInt, fd); if (ok != 0::CBool) (likely: True) { jump stg_block_noregs(); } else { @@ -2283,7 +2283,7 @@ stg_waitWritezh ( W_ fd ) (ok) = ccall syncIOWaitReady(Capability_iomgr(MyCapability()) "ptr", CurrentTSO "ptr", - /* IOWrite */ 1::I32, fd); + /* IOWrite */ 1::CInt, fd); if (ok != 0::CBool) (likely: True) { jump stg_block_noregs(); } else { ===================================== rts/posix/FdWakeup.h ===================================== @@ -29,12 +29,14 @@ #include "BeginPrivate.h" +#if defined(HAVE_PREEMPTION) void newFdWakeup(int *fd_r, int *fd_w); void closeFdWakeup(int fd_r, int fd_w); /* This is safe to use from a signal handler */ void sendFdWakeup(int fd_w); void collectFdWakeup(int fd_r); +#endif #include "EndPrivate.h" ===================================== rts/posix/Poll.c ===================================== @@ -41,6 +41,7 @@ #include "IOManagerInternals.h" #include "Timeout.h" +#include "FdWakeup.h" /****************************************************************************** @@ -107,8 +108,9 @@ timeout (if any) as the poll() timeout parameter. The CapIOManager structure for this I/O manager contains: ClosureTable aiop_table; - struct pollfd *aiop_poll_table; + struct pollfd *aiop_poll_table, *full_poll_table; StgTimeoutQueue *timeout_queue; + int interrupt_fd_r, interrupt_fd_w; We also support the Linux-specific ppoll API which supports higher resolution time delays -- nanoseconds rather than milliseconds as in classic poll(). It @@ -117,6 +119,15 @@ also allows the signal mask to be adjusted, but we do not make use of this. int ppoll(struct pollfd *fds, nfds_t nfds, const struct timespec *tmo_p, const sigset_t *sigmask); +We have both aiop_poll_table and full_poll_table. This is to cope with needing +to wait on the special extra file descriptor interrupt_fd_r. This fd is used to +support waking the I/O manager when we are blocked in a poll call. This +requires waiting on an extra fd that has no corresponding entry in the +aiop_table. To manage this quirk, we alias the aiop_poll_table to be the tail +of the full_poll_table and have the first entry of the full_poll_table be the +interrupt_fd_r. This means the aiop_poll_table indicies match up exactly with +the aiop_table, but still allows the full_poll_table to have an extra entry. + ******************************************************************************/ /* Forward declarations */ @@ -129,16 +140,34 @@ static void reportPollError(int res, nfds_t nfds) STG_NORETURN; void initCapabilityIOManagerPoll(CapIOManager *iomgr) { initClosureTable(&iomgr->aiop_table, ClosureTableCompact); - iomgr->aiop_poll_table = NULL; iomgr->timeout_queue = emptyTimeoutQueue(); + +#if defined(HAVE_PREEMPTION) + newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w); +#endif + + iomgr->full_poll_table = stgMallocBytes(sizeof(struct pollfd) /* size 1 */, + "initCapabilityIOManagerPoll"); + iomgr->full_poll_table[0] = (struct pollfd) { +#if defined(HAVE_PREEMPTION) + .fd = iomgr->interrupt_fd_r, + .events = POLLIN, +#else + .fd = -1, // unused + .events = 0, // unused +#endif + .revents = 0 + }; + iomgr->aiop_poll_table = iomgr->full_poll_table+1; /* hence empty */ } void freeCapabilityIOManagerPoll(CapIOManager *iomgr) { - if (iomgr->aiop_poll_table) { - stgFree(iomgr->aiop_poll_table); - } + stgFree(iomgr->full_poll_table); +#if defined(HAVE_PREEMPTION) + closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w); +#endif } @@ -295,7 +324,7 @@ static void notifyIOCompletion(CapIOManager *iomgr, StgAsyncIOOp *aiop) } -static void processIOCompletions(CapIOManager *iomgr, int ncompletions) +static bool 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 @@ -305,6 +334,19 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions) */ debugTrace(DEBUG_iomanager, "processIOCompletions(ncompletions = %d)", ncompletions); + + bool interrupt = false; +#if defined(HAVE_PREEMPTION) + /* If the interrupt_fd_r is ready, collect it */ + if (iomgr->full_poll_table[0].revents) { + ASSERT(iomgr->full_poll_table[0].fd == iomgr->interrupt_fd_r); + collectFdWakeup(iomgr->interrupt_fd_r); + ncompletions--; + interrupt = true; + debugTrace(DEBUG_iomanager, "Received interrupt in poll I/O manager"); + } +#endif + struct pollfd *aiop_poll_table = iomgr->aiop_poll_table; int n = ncompletions; int i = 0; @@ -357,11 +399,14 @@ static void processIOCompletions(CapIOManager *iomgr, int ncompletions) i++; } } + return interrupt; } void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { + ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1); + if (!isEmptyTimeoutQueue(iomgr->timeout_queue)) { Time now = getProcessElapsedTime(); processTimeoutCompletions(iomgr, now); @@ -369,20 +414,28 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) if (!isEmptyClosureTable(&iomgr->aiop_table)) { - nfds_t nfds = sizeClosureTable(&iomgr->aiop_table); +#if defined(HAVE_PREEMPTION) + /* the full_poll_table includes interrupt_fd_r */ + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1; + struct pollfd *poll_table = iomgr->full_poll_table; +#else + /* the aiop_poll_table does not include interrupt_fd_r */ + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 0; + struct pollfd *poll_table = iomgr->aiop_poll_table; +#endif /* Poll for I/O readiness, without waiting. */ #if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 /* We could use poll here, since we use no timeout, but for consistency we use the same syscall as at the other call site. */ struct timespec tv = (struct timespec) { .tv_sec = 0, .tv_nsec = 0 }; - int res = ppoll(iomgr->aiop_poll_table, nfds, &tv, NULL); + int res = ppoll(poll_table, nfds, &tv, NULL); debugTrace(DEBUG_iomanager, "ppoll(nfds = %d, timeout.sec = 0, timeout.nsec = 0) = %d", nfds, res); #else - int res = poll(iomgr->aiop_poll_table, nfds, 0); + int res = poll(poll_table, nfds, 0); debugTrace(DEBUG_iomanager, "poll(nfds = %d, timeout_ms = 0) = %d", @@ -408,8 +461,12 @@ void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } -void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) +bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) { + bool interrupt = false; /* got woken up via interruptIOManager */ + + ASSERT(iomgr->aiop_poll_table == iomgr->full_poll_table+1); + /* 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 @@ -431,6 +488,16 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) */ bool wait = emptyRunQueue(iomgr->cap); +#if defined(HAVE_PREEMPTION) + /* the full_poll_table includes interrupt_fd_r */ + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 1; + struct pollfd *poll_table = iomgr->full_poll_table; +#else + /* the aiop_poll_table does not include interrupt_fd_r */ + nfds_t nfds = sizeClosureTable(&iomgr->aiop_table) + 0; + struct pollfd *poll_table = iomgr->aiop_poll_table; +#endif + /* Decide if we are going to wait if no I/O is ready, either: * poll only, wait indefinitely, or wait until a timeout. */ @@ -442,9 +509,8 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) #endif /* Check for I/O readiness, possibly waiting. */ - nfds_t nfds = sizeClosureTable(&iomgr->aiop_table); #if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 - int res = ppoll(iomgr->aiop_poll_table, nfds, timeout_ns, NULL); + int res = ppoll(poll_table, nfds, timeout_ns, NULL); debugTrace(DEBUG_iomanager, "ppoll(nfds = %d, timeout.sec = %d, timeout.nsec = %d) = %d", @@ -452,7 +518,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) timeout_ns == NULL ? 0 : timeout_ns->tv_nsec, res); #else - int res = poll(iomgr->aiop_poll_table, nfds, timeout_ms); + int res = poll(poll_table, nfds, timeout_ms); debugTrace(DEBUG_iomanager, "poll(nfds = %d, timeout_ms = %d) = %d", @@ -474,7 +540,7 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } else if (res > 0) { int ncompletions = res; ASSERT(ncompletions <= (int)nfds); - processIOCompletions(iomgr, ncompletions); + interrupt = processIOCompletions(iomgr, ncompletions); // FIXME: do we also need to check for timeout completions now? // we have a non-empty queue, but if !wait then we have also moved // on and so we sould check for timeouts. @@ -502,7 +568,9 @@ void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr) } } while (emptyRunQueue(iomgr->cap) + && !interrupt && (getSchedState() == SCHED_RUNNING)); + return !interrupt; } static void reportPollError(int res, nfds_t nfds) @@ -521,6 +589,14 @@ static void reportPollError(int res, nfds_t nfds) } +void interruptIOManagerPoll(CapIOManager *iomgr) +{ +#if defined(HAVE_PREEMPTION) + sendFdWakeup(iomgr->interrupt_fd_w); +#endif +} + + /* Helper function to double the size of the aiop_table and aiop_poll_table. */ static bool enlargeTables(CapIOManager *iomgr) @@ -531,13 +607,17 @@ static bool enlargeTables(CapIOManager *iomgr) bool ok = enlargeClosureTable(iomgr->cap, &iomgr->aiop_table, newcapacity); if (RTS_UNLIKELY(!ok)) return false; - /* Update the auxiliary aiop_poll_table to match */ - struct pollfd *aiop_poll_table; - aiop_poll_table = stgReallocBytes(iomgr->aiop_poll_table, - sizeof(struct pollfd) * newcapacity, - "Poll.c: enlargeTables"); - iomgr->aiop_poll_table = aiop_poll_table; + /* Update the auxiliary aiop_poll_table to match. The full_poll_table is + * one bigger than the aiop_poll_table, since it has an extra entry at the + * front for interrupt_fd_r, with no corresponding aiop. */ + iomgr->full_poll_table = + stgReallocBytes(iomgr->full_poll_table, + sizeof(struct pollfd) * (newcapacity+1), + "Poll.c: enlargeTables"); + iomgr->aiop_poll_table = iomgr->full_poll_table+1; + /* Initialise the new part of the aiop_poll_table */ + struct pollfd *aiop_poll_table = iomgr->aiop_poll_table; for (int i = oldcapacity; i < newcapacity; i++) { aiop_poll_table[i] = (struct pollfd) { .fd = -1, ===================================== rts/posix/Poll.h ===================================== @@ -32,7 +32,8 @@ void asyncIOCancelPoll(CapIOManager *iomgr, StgAsyncIOOp *aiop); /* Scheduler operations */ bool anyPendingTimeoutsOrIOPoll(CapIOManager *iomgr); void pollCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); -void awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); +bool awaitCompletedTimeoutsOrIOPoll(CapIOManager *iomgr); +void interruptIOManagerPoll(CapIOManager *iomgr); #endif /* IOMGR_ENABLED_POLL */ ===================================== rts/posix/Select.c ===================================== @@ -22,6 +22,7 @@ #include "IOManagerInternals.h" #include "Stats.h" #include "GetTime.h" +#include "FdWakeup.h" # if defined(HAVE_SYS_SELECT_H) # include <sys/select.h> @@ -54,6 +55,39 @@ #define TimeToLowResTimeRoundUp(t) (t) #endif +void initCapabilityIOManagerSelect(CapIOManager *iomgr) +{ + iomgr->blocked_queue_hd = END_TSO_QUEUE; + iomgr->blocked_queue_tl = END_TSO_QUEUE; + iomgr->sleeping_queue = END_TSO_QUEUE; + +#if defined(HAVE_PREEMPTION) + newFdWakeup(&iomgr->interrupt_fd_r, &iomgr->interrupt_fd_w); + + /* Would never happen in a standalone process, but could plausibly happen + * if the RTS is used within another process that already has many open fds. + */ + if (iomgr->interrupt_fd_r < 0 || iomgr->interrupt_fd_r >= (int)FD_SETSIZE || + iomgr->interrupt_fd_w < 0 || iomgr->interrupt_fd_w >= (int)FD_SETSIZE) { + barf("initCapabilityIOManagerSelect: fds out of select range"); + } +#endif +} + +void freeCapabilityIOManagerSelect(CapIOManager *iomgr) +{ +#if defined(HAVE_PREEMPTION) + closeFdWakeup(iomgr->interrupt_fd_r, iomgr->interrupt_fd_w); +#endif +} + +void interruptIOManagerSelect(CapIOManager *iomgr) +{ +#if defined(HAVE_PREEMPTION) + sendFdWakeup(iomgr->interrupt_fd_w); +#endif +} + /* * Return the time since the program started, in LowResTime, * rounded down. @@ -215,7 +249,7 @@ static enum FdState fdPollWriteState (int fd) * not write handles. * */ -void +bool awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) { StgTSO *tso, *prev, *next; @@ -225,6 +259,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) bool seen_bad_fd = false; struct timeval tv, *ptv; LowResTime now; + bool interrupt = false; /* got interrupted up via interruptIOManager */ IF_DEBUG(scheduler, debugBelch("scheduler: checking for threads blocked on I/O"); @@ -243,7 +278,7 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) now = getLowResTimeOfDay(); if (wakeUpSleepingThreads(iomgr, now)) { - return; + return true; } /* @@ -252,6 +287,16 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) FD_ZERO(&rfd); FD_ZERO(&wfd); +#if defined(HAVE_PREEMPTION) + /* We're always interested in our interrupt fd */ + { + int fd = iomgr->interrupt_fd_r; + maxfd = (fd > maxfd) ? fd : maxfd; + ASSERT(fd >= 0 && fd < (int)FD_SETSIZE); // checked during init + FD_SET(fd, &rfd); + } +#endif + for(tso = iomgr->blocked_queue_hd; tso != END_TSO_QUEUE; tso = next) { @@ -354,14 +399,14 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) #if defined(RTS_USER_SIGNALS) if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) { startSignalHandlers(iomgr->cap); - return; /* still hold the lock */ + return true; /* still hold the lock */ } #endif /* we were interrupted, return to the scheduler immediately. */ if (getSchedState() >= SCHED_INTERRUPTING) { - return; /* still hold the lock */ + return true; /* still hold the lock */ } /* check for threads that need waking up @@ -372,10 +417,19 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) * I/O and run them. */ if (!emptyRunQueue(iomgr->cap)) { - return; /* still hold the lock */ + return true; /* still hold the lock */ } } +#if defined(HAVE_PREEMPTION) + /* If the interrupt_fd_r is ready, collect it */ + if (FD_ISSET(iomgr->interrupt_fd_r, &rfd)) { + collectFdWakeup(iomgr->interrupt_fd_r); + interrupt = true; + debugTrace(DEBUG_iomanager, "Received interrupt in select I/O manager"); + } +#endif + /* Step through the waiting queue, unblocking every thread that now has * a file descriptor in a ready state. */ @@ -458,7 +512,9 @@ awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait) } } while (wait && getSchedState() == SCHED_RUNNING - && emptyRunQueue(iomgr->cap)); + && emptyRunQueue(iomgr->cap) + && !interrupt); + return !interrupt; } #endif /* IOMGR_ENABLED_SELECT */ ===================================== rts/posix/Select.h ===================================== @@ -15,7 +15,12 @@ typedef StgWord LowResTime; LowResTime getDelayTarget (HsInt us); -void awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait); +void initCapabilityIOManagerSelect(CapIOManager *iomgr); +void freeCapabilityIOManagerSelect(CapIOManager *iomgr); +void wakeupIOManagerSelect(CapIOManager *iomgr); + +bool awaitCompletedTimeoutsOrIOSelect(CapIOManager *iomgr, bool wait); +void interruptIOManagerSelect(CapIOManager *iomgr); #include "EndPrivate.h" ===================================== rts/win32/AsyncMIO.c ===================================== @@ -221,8 +221,12 @@ shutdownAsyncIO(bool wait_threads) * requests to make further progress. In the latter scenario, * awaitRequests() will simply block waiting for worker threads * to complete if the 'completedTable' is empty. + * + * The result reports if the wait completed successfully (typically with some + * work available), or was interrupted by abandonRequestWait(), with true + * meaning completed, and false meaning interrupted. */ -int +bool awaitRequests(bool wait) { #if !defined(THREADED_RTS) @@ -246,7 +250,7 @@ start: #endif ) { OS_RELEASE_LOCK(&queue_lock); - return 0; + return true; } if (completed_hw == 0) { // empty table, drop lock and wait @@ -259,22 +263,24 @@ start: // a request was completed break; case WAIT_OBJECT_0 + 1: + // abandon_req_wait signaled, by abandonRequestWait() + return false; case WAIT_TIMEOUT: // timeout (unlikely) or told to abandon waiting - return 0; + return true; case WAIT_FAILED: { DWORD dw = GetLastError(); fprintf(stderr, "awaitRequests: wait failed -- " "error code: %lu\n", dw); fflush(stderr); - return 0; + return true; } default: fprintf(stderr, "awaitRequests: unexpected wait return " "code %lu\n", dwRes); fflush(stderr); - return 0; + return true; } } else { - return 0; + return true; } goto start; } else { @@ -352,7 +358,7 @@ start: completed_hw = 0; ResetEvent(completed_req_event); OS_RELEASE_LOCK(&queue_lock); - return 1; + return true; } #endif /* !THREADED_RTS */ } @@ -383,12 +389,6 @@ abandonRequestWait( void ) interruptIOManagerEvent (); } -void -resetAbandonRequestWait( void ) -{ - ResetEvent(abandon_req_wait); -} - #endif /* !defined(THREADED_RTS) */ HsInt rts_EINTR(void) ===================================== rts/win32/AsyncMIO.h ===================================== @@ -25,7 +25,7 @@ extern unsigned int addDoProcRequest(void* proc, void* param); extern int startupAsyncIO(void); extern void shutdownAsyncIO(bool wait_threads); -extern int awaitRequests(bool wait); +extern bool awaitRequests(bool wait); extern void abandonRequestWait(void); extern void resetAbandonRequestWait(void); ===================================== rts/win32/AwaitEvent.c ===================================== @@ -28,17 +28,21 @@ // Protected by sched_mutex. static bool workerWaitingForRequests = false; -void +bool awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait) { + bool interrupt = false; do { /* Try to de-queue completed IO requests */ workerWaitingForRequests = true; if (is_io_mng_native_p()) awaitAsyncRequests(wait); + /* FIXME: no support yet for interrupting in WinIO I/O manager + * See issue #27403 + */ else - awaitRequests(wait); + interrupt = !awaitRequests(wait); workerWaitingForRequests = false; // If a signal was raised, we need to service it @@ -47,11 +51,12 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait) // does it and I'm feeling too paranoid to refactor it today --SDM if (stg_pending_events != 0) { startSignalHandlers(cap); - return; + // This will normally cause emptyRunQueue to become false and + // thus we will drop out of the loop. } - // The return value from awaitRequests() is a red herring: ignore - // it. Return to the scheduler if !wait, or + // The return value from awaitRequests() reports if it was interrupted by + // abandonRequestWait(). Return to the scheduler if !wait, or // // - we were interrupted // - the run-queue is now non- empty @@ -59,6 +64,8 @@ awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait) } while (wait && getSchedState() == SCHED_RUNNING && emptyRunQueue(cap) + && !interrupt ); + return !interrupt; } #endif ===================================== rts/win32/AwaitEvent.h ===================================== @@ -2,6 +2,6 @@ #include "BeginPrivate.h" -void awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait); +bool awaitCompletedTimeoutsOrIOWin32(Capability *cap, bool wait); #include "EndPrivate.h" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d7e7e5e44d86796a3ebdf0d65bca… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d7e7e5e44d86796a3ebdf0d65bca… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/dcoutts/io-manager-selectbis
by Duncan Coutts (＠dcoutts) 17 Jul '26

17 Jul '26

Duncan Coutts pushed new branch wip/dcoutts/io-manager-selectbis at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/dcoutts/io-manager-selectbis You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/ci-make-install-j
by Cheng Shao (＠TerrorJack) 17 Jul '26

17 Jul '26

Cheng Shao deleted branch wip/ci-make-install-j at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] base: re-export GHC.Environment.getFullArgs from System.Environment
by Marge Bot (＠marge-bot) 17 Jul '26

17 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: fe3b059c by Andrew Lelechenko at 2026-07-17T04:58:26-04:00 base: re-export GHC.Environment.getFullArgs from System.Environment CLC proposal https://github.com/haskell/core-libraries-committee/issues/431 - - - - - 5 changed files: - libraries/base/changelog.md - libraries/base/src/System/Environment.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 Changes: ===================================== libraries/base/changelog.md ===================================== @@ -2,6 +2,7 @@ ## 4.24.0.0 *TBA* * Give `setBit`, `clearBit` and `complementBit` explicit definitions in `instance Bits Integer`, reducing intermediate allocations. ([CLC proposal #423](https://github.com/haskell/core-libraries-committee/issues/423)) + * Export `GHC.Environment.getFullArgs` from `System.Environment`. ([CLC proposal #431](https://github.com/haskell/core-libraries-committee/issues/431)) * Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402)) * Add `Data.List.NonEmpty.{zip{3..7},zipWith{3..7},unzip{3..7}}` ([CLC proposal #409)(https://github.com/haskell/core-libraries-committee/issues/409)) * Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412)) ===================================== libraries/base/src/System/Environment.hs ===================================== @@ -15,6 +15,7 @@ module System.Environment ( getArgs, + getFullArgs, getProgName, executablePath, getExecutablePath, @@ -27,4 +28,5 @@ module System.Environment getEnvironment, ) where +import GHC.Internal.Environment (getFullArgs) import GHC.Internal.System.Environment ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -9885,6 +9885,7 @@ module System.Environment where getEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO GHC.Internal.Base.String getEnvironment :: GHC.Internal.Types.IO [(GHC.Internal.Base.String, GHC.Internal.Base.String)] getExecutablePath :: GHC.Internal.Types.IO GHC.Internal.IO.FilePath + getFullArgs :: GHC.Internal.Types.IO [GHC.Internal.Base.String] getProgName :: GHC.Internal.Types.IO GHC.Internal.Base.String lookupEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) setEnv :: GHC.Internal.Base.String -> GHC.Internal.Base.String -> GHC.Internal.Types.IO () ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -9923,6 +9923,7 @@ module System.Environment where getEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO GHC.Internal.Base.String getEnvironment :: GHC.Internal.Types.IO [(GHC.Internal.Base.String, GHC.Internal.Base.String)] getExecutablePath :: GHC.Internal.Types.IO GHC.Internal.IO.FilePath + getFullArgs :: GHC.Internal.Types.IO [GHC.Internal.Base.String] getProgName :: GHC.Internal.Types.IO GHC.Internal.Base.String lookupEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) setEnv :: GHC.Internal.Base.String -> GHC.Internal.Base.String -> GHC.Internal.Types.IO () ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -10165,6 +10165,7 @@ module System.Environment where getEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO GHC.Internal.Base.String getEnvironment :: GHC.Internal.Types.IO [(GHC.Internal.Base.String, GHC.Internal.Base.String)] getExecutablePath :: GHC.Internal.Types.IO GHC.Internal.IO.FilePath + getFullArgs :: GHC.Internal.Types.IO [GHC.Internal.Base.String] getProgName :: GHC.Internal.Types.IO GHC.Internal.Base.String lookupEnv :: GHC.Internal.Base.String -> GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) setEnv :: GHC.Internal.Base.String -> GHC.Internal.Base.String -> GHC.Internal.Types.IO () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe3b059c714be22dac658a620a2b5a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe3b059c714be22dac658a620a2b5a0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][master] Mark various language extension flags as deprecated (see #27329)
by Marge Bot (＠marge-bot) 17 Jul '26

17 Jul '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d5ae6906 by Adam Gundry at 2026-07-17T04:57:43-04:00 Mark various language extension flags as deprecated (see #27329) The following language extensions are now deprecated: - AlternativeLayoutRule - AlternativeLayoutRuleTransitional - ParallelArrays - PolymorphicComponents - Rank2Types In addition, the warning `-Walternative-layout-rule-transitional` has been marked as deprecated, as it is emitted only under the deprecated extension `XAlternativeLayoutRuleTransitional`. - - - - - 49 changed files: - + changelog.d/T27329 - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Tc/Types/Rank.hs - docs/users_guide/expected-undocumented-flags.txt - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/static_pointers.rst - libraries/ghc-internal/ghc-internal.cabal.in - testsuite/tests/backpack/should_compile/T13149.bkp - testsuite/tests/determinism/determ017/A.hs - testsuite/tests/ghci/scripts/T12005.script - testsuite/tests/haddock/perf/Fold.hs - testsuite/tests/indexed-types/should_fail/T7354.hs - testsuite/tests/layout/layout001.stdout - testsuite/tests/layout/layout002.stdout - testsuite/tests/layout/layout003.stdout - testsuite/tests/layout/layout004.stdout - testsuite/tests/layout/layout005.stdout - testsuite/tests/layout/layout006.stdout - testsuite/tests/layout/layout007.stdout - testsuite/tests/layout/layout008.stdout - testsuite/tests/layout/layout009.stdout - testsuite/tests/linear/should_compile/T1735Min.hs - + testsuite/tests/parser/should_compile/T13087.stderr - testsuite/tests/parser/should_fail/T8431.stderr - testsuite/tests/parser/should_fail/readFail038.stderr - testsuite/tests/perf/compiler/T3064.hs - testsuite/tests/polykinds/T7594.hs - testsuite/tests/programs/thurston-modular-arith/Main.hs - testsuite/tests/rts/ipe/IpeStats/Fold.hs - testsuite/tests/simplCore/should_compile/T11562.hs - testsuite/tests/simplCore/should_run/T3591.hs - testsuite/tests/typecheck/should_compile/DeepSubsumption02.hs - testsuite/tests/typecheck/should_compile/T12507.hs - testsuite/tests/typecheck/should_compile/T13951.hs - testsuite/tests/typecheck/should_compile/T18920.hs - testsuite/tests/typecheck/should_compile/T2595.hs - testsuite/tests/typecheck/should_compile/T7541.hs - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7368a.hs - testsuite/tests/typecheck/should_run/T1735_Help/Basics.hs - testsuite/tests/typecheck/should_run/T3731-short.hs - testsuite/tests/typecheck/should_run/T3731.hs - testsuite/tests/typecheck/should_run/church.hs - testsuite/tests/typecheck/should_run/tcrun008.hs - testsuite/tests/typecheck/should_run/tcrun017.hs - testsuite/tests/typecheck/should_run/tcrun026.hs - testsuite/tests/typecheck/should_run/tcrun035.hs - testsuite/tests/typecheck/should_run/tcrun036.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5ae69061e52b63cef3a944fb98ede9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d5ae69061e52b63cef3a944fb98ede9… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0