- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/ubsan] 42 commits: Add a fast-path for args=[] to occAnalApp
by Cheng Shao (＠TerrorJack) 08 Dec '25

08 Dec '25

Cheng Shao pushed to branch wip/ubsan at Glasgow Haskell Compiler / GHC Commits: 48a3ed57 by Simon Peyton Jones at 2025-11-25T15:33:54+00:00 Add a fast-path for args=[] to occAnalApp In the common case of having not arguments, occAnalApp was doing redundant work. - - - - - 951e5ed9 by Simon Peyton Jones at 2025-11-25T15:33:54+00:00 Fix a performance hole in the occurrence analyser As #26425 showed, the clever stuff in Note [Occurrence analysis for join points] does a lot of duplication of usage details. This patch improved matters with a little fancy footwork. It is described in the new (W4) of the same Note. Compile-time allocations go down slightly. Here are the changes of +/- 0.5% or more: T13253(normal) 329,369,244 326,395,544 -0.9% T13253-spj(normal) 66,410,496 66,095,864 -0.5% T15630(normal) 129,797,200 128,663,136 -0.9% T15630a(normal) 129,212,408 128,027,560 -0.9% T16577(normal) 6,756,706,896 6,723,028,512 -0.5% T18282(normal) 128,462,070 125,808,584 -2.1% GOOD T18698a(normal) 208,418,305 202,037,336 -3.1% GOOD T18730(optasm) 136,981,756 136,208,136 -0.6% T18923(normal) 58,103,088 57,745,840 -0.6% T19695(normal) 1,386,306,272 1,365,609,416 -1.5% T26425(normal) 3,344,402,957 2,457,811,664 -26.5% GOOD T6048(optasm) 79,763,816 79,212,760 -0.7% T9020(optasm) 225,278,408 223,682,440 -0.7% T9961(normal) 303,810,717 300,729,168 -1.0% GOOD geo. mean -0.5% minimum -26.5% maximum +0.4% Metric Decrease: T18282 T18698a T26425 T9961 - - - - - f1959dfc by Simon Peyton Jones at 2025-11-26T11:58:07+00:00 Remove a quadratic-cost assertion check in mkCoreApp See the new Note [Assertion checking in mkCoreApp] - - - - - 98fa0d36 by Simon Hengel at 2025-11-27T17:54:57-05:00 Fix typo in docs/users_guide/exts/type_families.rst - - - - - 5b97e5ce by Simon Hengel at 2025-11-27T17:55:37-05:00 Fix broken RankNTypes example in user's guide - - - - - fa2aaa00 by Simon Peyton Jones at 2025-11-27T17:56:18-05:00 Switch off specialisation in ExactPrint In !15057 (where we re-introduced -fpolymoprhic-specialisation) we found that ExactPrint's compile time blew up by a factor of 5. It turned out to be caused by bazillions of specialisations of `markAnnotated`. Since ExactPrint isn't perf-critical, it does not seem worth taking the performance hit, so this patch switches off specialisation in this one module. - - - - - 1fd25987 by Simon Peyton Jones at 2025-11-27T17:56:18-05:00 Switch -fpolymorphic-specialisation on by default This patch addresses #23559. Now that !10479 has landed and #26329 is fixed, we can switch on polymorphic specialisation by default, addressing a bunch of other tickets listed in #23559. Metric changes: * CoOpt_Singleton: +4% compiler allocations: we just get more specialisations * info_table_map_perf: -20% decrease in compiler allocations. This is caused by using -fno-specialise in ExactPrint.hs Without that change we get a 4x blow-up in compile time; see !15058 for details Metric Decrease: info_table_map_perf Metric Increase: CoOpt_Singletons - - - - - b7fe7445 by Matthew Pickering at 2025-11-27T17:56:59-05:00 rts: Fix a deadlock with eventlog flush interval and RTS shutdown The ghc_ticker thread attempts to flush at the eventlog tick interval, this requires waiting to take all capabilities. At the same time, the main thread is shutting down, the schedule is stopped and then we wait for the ticker thread to finish. Therefore we are deadlocked. The solution is to use `newBoundTask/exitMyTask`, so that flushing can cooperate with the scheduler shutdown. Fixes #26573 - - - - - 1d4a1229 by sheaf at 2025-11-27T17:58:02-05:00 SimpleOpt: don't subst in pushCoercionIntoLambda It was noticed in #26589 that the change in 15b311be was incorrect: the simple optimiser carries two different substitution-like pieces of information: 'soe_subst' (from InVar to OutExpr) and 'soe_inl' (from InId to InExpr). It is thus incorrect to have 'pushCoercionIntoLambda' apply the substitution from 'soe_subst' while discarding 'soe_inl' entirely, which is what was done in 15b311be. Instead, we change back pushCoercionIntoLambda to take an InScopeSet, and optimise the lambda before calling 'pushCoercionIntoLambda' to avoid mixing InExpr with OutExpr, or mixing two InExpr with different environments. We can then call 'soeZapSubst' without problems. Fixes #26588 #26589 - - - - - 84a087d5 by Sylvain Henry at 2025-11-28T17:35:28-05:00 Fix PIC jump tables on Windows (#24016) Avoid overflows in jump tables by using a base label closer to the jump targets. See added Note [Jump tables] - - - - - 82db7042 by Zubin Duggal at 2025-11-28T17:36:10-05:00 rts/linker/PEi386: Copy strings before they are inserted into LoadedDllCache. The original strings are temporary and might be freed at an arbitrary point. Fixes #26613 - - - - - ff3f0d09 by Ben Gamari at 2025-11-29T18:34:28-05:00 gitlab-ci: Run ghcup-metadata jobs on OpenCape runners This significantly reduces our egress traffic and makes the jobs significantly faster. - - - - - ef0dc33b by Matthew Pickering at 2025-11-29T18:35:10-05:00 Use 'OsPath' in getModificationTimeIfExists This part of the compiler is quite hot during recompilation checking in particular since the filepaths will be translated to a string. It is better to use the 'OsPath' native function, which turns out to be easy to do. - - - - - fa3bd0a6 by Georgios Karachalias at 2025-11-29T18:36:05-05:00 Use OsPath in PkgDbRef and UnitDatabase, not FilePath - - - - - 0d7c05ec by Ben Gamari at 2025-12-01T03:13:46-05:00 hadrian: Place user options after package arguments This makes it easier for the user to override the default package arguments with `UserSettings.hs`. Fixes #25821. ------------------------- Metric Decrease: T14697 ------------------------- - - - - - 3b2c4598 by Vladislav Zavialov at 2025-12-01T03:14:29-05:00 Namespace-specified wildcards in import/export lists (#25901) This change adds support for top-level namespace-specified wildcards `type ..` and `data ..` to import and export lists. Examples: import M (type ..) -- imports all type and class constructors from M import M (data ..) -- imports all data constructors and terms from M module M (type .., f) where -- exports all type and class constructors defined in M, -- plus the function 'f' The primary intended usage of this feature is in combination with module aliases, allowing namespace disambiguation: import Data.Proxy as T (type ..) -- T.Proxy is unambiguously the type constructor import Data.Proxy as D (data ..) -- D.Proxy is unambiguously the data constructor The patch accounts for the interactions of wildcards with: * Imports with `hiding` clauses * Import warnings -Wunused-imports, -Wdodgy-imports * Export warnings -Wduplicate-exports, -Wdodgy-exports Summary of the changes: 1. Move the NamespaceSpecifier type from GHC.Hs.Binds to GHC.Hs.Basic, making it possible to use it in more places in the AST. 2. Extend the AST (type: IE) with a representation of `..`, `type ..`, and `data ..` (constructor: IEWholeNamespace). Per the proposal, the plain `..` is always rejected with a dedicated error message. 3. Extend the grammar in Parser.y with productions for `..`, `type ..`, and `data ..` in both import and export lists. 4. Implement wildcard imports by updating the `filterImports` function in GHC.Rename.Names; the logic for IEWholeNamespace is roughly modeled after the Nothing (no explicit import list) case. 5. Implement wildcard exports by updating the `exports_from_avail` function in GHC.Tc.Gen.Export; the logic for IEWholeNamespace is closely modeled after the IEModuleContents case. 6. Refactor and extend diagnostics to report the new warnings and errors. See PsErrPlainWildcardImport, DodgyImportsWildcard, PsErrPlainWildcardExport, DodgyExportsWildcard, TcRnDupeWildcardExport. Note that this patch is specifically about top-level import/export items. Subordinate import/export items are left unchanged. - - - - - c71faa76 by Luite Stegeman at 2025-12-01T03:16:05-05:00 rts: Handle overflow of ELF section header string table If the section header string table is stored in a section greater than or equal to SHN_LORESERVE (0xff00), the 16-bit field e_shstrndx in the ELF header does not contain the section number, but rather an overflow value SHN_XINDEX (0xffff) indicating that we need to look elsewhere. This fixes the linker by not using e_shstrndx directly but calling elf_shstrndx, which correctly handles the SHN_XINDEX value. Fixes #26603 - - - - - ab20eb54 by Mike Pilgrem at 2025-12-01T22:46:55+00:00 Re CLC issue 292 Warn GHC.Internal.List.{init,last} are partial Also corrects the warning for `tail` to refer to `Data.List.uncons` (like the existing warning for `head`). In module `Settings.Warnings`, applies `-Wno-x-partial` to the `filepath`, and `parsec` packages (outside GHC's repository). Also bumps submodules. - - - - - fc1d7f79 by Jade Lovelace at 2025-12-02T11:04:09-05:00 docs: fix StandaloneKindSignatures in DataKinds docs These should be `type` as otherwise GHC reports a duplicate definition error. - - - - - beae879b by Rodrigo Mesquita at 2025-12-03T15:42:37+01:00 task: Substitute some datatypes for newtypes * Substitutes some data type declarations for newtype declarations * Adds comment to `LlvmConfigCache`, which must decidedly not be a newtype. Fixes #23555 - - - - - 3bd7dd44 by mangoiv at 2025-12-04T04:36:45-05:00 Renamer: reinstate the template haskell level check in notFound Out-of-scope names might be caused by a staging error, as is explained by Note [Out of scope might be a staging error] in GHC.Tc.Utils.Env.hs. This logic was assumed to be dead code after 217caad1 and has thus been removed. This commit reintroduces it and thus fixes issue #26099. - - - - - 0318010b by Zubin Duggal at 2025-12-04T04:37:27-05:00 testlib: Optionally include the way name in the expected output file This allows us to have different outputs for different ways. - - - - - 6d945fdd by Zubin Duggal at 2025-12-04T04:37:27-05:00 testsuite: Accept output of tests failing in ext-interp way due to differing compilation requirements Fixes #26552 - - - - - 0ffc5243 by Cheng Shao at 2025-12-04T04:38:09-05:00 devx: minor fixes for compile_flags.txt This patch includes minor fixes for compile_flags.txt to improve developer experience when using clangd as language server to hack on RTS C sources: - Ensure `-fPIC` is passed and `__PIC__` is defined, to be coherent with `-DDYNAMIC` and ensure the `__PIC__` guarded code paths are indexed - Add the missing `-DRtsWay` definition, otherwise a few source files like `RtsUtils.c` and `Trace.c` would produce clangd errors - - - - - e36a5fcb by Matthew Pickering at 2025-12-05T16:25:57-05:00 Add support for building bytecode libraries A bytecode library is a collection of bytecode files (.gbc) and a library which combines together additional object files. A bytecode library is created by invoking GHC with the `-bytecodelib` flag. A library can be created from in-memory `ModuleByteCode` linkables or by passing `.gbc` files as arguments on the command line. Fixes #26298 - - - - - 8f9ae339 by Matthew Pickering at 2025-12-05T16:25:57-05:00 Load bytecode libraries to satisfy package dependencies This commit allows you to use a bytecode library to satisfy a package dependency when using the interpreter. If a user enables `-fprefer-byte-code`, then if a package provides a bytecode library, that will be loaded and used to satisfy the dependency. The main change is to separate the relevant parts of the `LoaderState` into external and home package byte code. Bytecode is loaded into either the home package or external part (similar to HPT/EPS split), HPT bytecode can be unloaded. External bytecode is never unloaded. The unload function has also only been called with an empty list of "stable linkables" for a long time. It has been modified to directly implement a complete unloading of the home package bytecode linkables. At the moment, the bytecode libraries are found in the "library-dirs" field from the package description. In the future when `Cabal` implements support for "bytecode-library-dirs" field, we can read the bytecode libraries from there. No changes to the Cabal submodule are necessary at the moment. Four new tests are added in testsuite/tests/cabal, which generate fake package descriptions and test loading the libraries into GHCi. Fixes #26298 - - - - - 54458ce4 by mangoiv at 2025-12-05T16:26:50-05:00 ExplicitLevelImports: improve documentation of the code - more explicit names for variable names like `flg` or `topLevel` - don't pass the same value twice to functions - some explanations of interesting but undocumented code paths - adjust comment to not mention non-existent error message - - - - - c7061392 by mangoiv at 2025-12-05T16:27:42-05:00 driver: don't expect nodes to exist when checking paths between them In `mgQueryZero`, previously node lookups were expected to never fail, i.e. it was expected that when calculating the path between two nodes in a zero level import graph, both nodes would always exist. This is not the case, e.g. in some situations involving exact names (see the test-case). The fix is to first check whether the node is present in the graph at all, instead of panicking, just to report that there is no path. Closes #26568 - - - - - d6cf8463 by Peng Fan at 2025-12-06T11:06:28-05:00 NCG/LA64: Simplify genCCall into two parts genCCall is too long, so it's been simplified into two parts: genPrim and genLibCCall. Suggested by Andreas Klebinger - - - - - 9d371d23 by Matthew Pickering at 2025-12-06T11:07:09-05:00 hadrian: Use a response file to invoke GHC for dep gathering. In some cases we construct an argument list too long for GHC to handle directly on windows. This happens when we generate the dependency file because the command line will contain references to a large number of .hs files. To avoid this we now invoke GHC using a response file when generating dependencies to sidestep length limitations. Note that we only pass the actual file names in the dependency file. Why? Because this side-steps #26560 - - - - - 0043bfb0 by Marc Scholten at 2025-12-06T11:08:03-05:00 update xhtml to 3000.4.0.0 haddock-api: bump xhtml bounds haddock-api: use lazy text instead of string to support xhtml 3000.4.0.0 Bumping submodule xhtml to 3000.4.0.0 add xhtml to stage0Packages remove unused import of writeUtf8File Remove redundant import Update haddock golden files for xhtml 3000.4.0.0 Metric Decrease: haddock.Cabal haddock.base - - - - - fc958fc9 by Julian Ospald at 2025-12-06T11:08:53-05:00 rts: Fix object file format detection in loadArchive Commit 76d1041dfa4b96108cfdd22b07f2b3feb424dcbe seems to have introduced this bug, ultimately leading to failure of test T11788. I can only theorize that this test isn't run in upstream's CI, because they don't build a static GHC. The culprit is that we go through the thin archive, trying to follow the members on the filesystem, but don't re-identify the new object format of the member. This pins `object_fmt` to `NotObject` from the thin archive. Thanks to @angerman for spotting this. - - - - - 0f297f6e by mangoiv at 2025-12-06T11:09:44-05:00 users' guide: don't use f strings in the python script to ensure compatibility with python 3.5 - - - - - 3bfe7aa2 by Matthew Pickering at 2025-12-07T12:18:57-05:00 ci: Try using multi repl in ghc-in-ghci test This should be quite a bit faster than the ./hadrian/ghci command as it doesn't properly build all the dependencies. - - - - - 2ef1601a by Rodrigo Mesquita at 2025-12-07T12:19:38-05:00 Stack.Decode: Don't error on bitmap size 0 A RET_BCO may have a bitmap with no payload. In that case, the bitmap = 0. One can observe this by using -ddump-bcos and interpreting ``` main = pure () ``` Observe, for instance, that the BCO for this main function has size 0: ``` ProtoBCO Main.main#0: \u [] break<main:Main,0>() GHC.Internal.Base.pure GHC.Internal.Base.$fApplicativeIO GHC.Internal.Tuple.() bitmap: 0 [] BRK_FUN <breakarray> main:Main 0 <cc> PACK () 0 PUSH_G GHC.Internal.Base.$fApplicativeIO PUSH_APPLY_PP PUSH_G GHC.Internal.Base.pure ENTER ``` Perhaps we never tried to decode a stack in which a BCO like this was present. However, for the debugger, we want to decode stacks of threads stopped at breakpoints, and these kind of BCOs do get on a stack under e.g. `stg_apply_interp_info` frames. See the accompanying test in the next commit for an example to trigger the bug this commit fixes. Fixes #26640 - - - - - 747153d2 by Rodrigo Mesquita at 2025-12-07T12:19:38-05:00 Add test for #26640 - - - - - f487ae79 by Cheng Shao at 2025-12-08T19:07:33+01:00 hadrian: add support for building with UndefinedBehaviorSanitizer This patch adds a +ubsan flavour transformer to hadrian to build all stage1+ C/C++ code with UndefinedBehaviorSanitizer. This is particularly useful to catch potential undefined behavior in the RTS codebase. - - - - - 87851e99 by Cheng Shao at 2025-12-08T19:07:33+01:00 configure: bump LlvmMaxVersion to 22 This commit bumps LlvmMaxVersion to 22; 21.x releases have been available since Aug 26th, 2025 and there's no regressions with 21.x so far. This bump is also required for updating fedora image to 43. - - - - - 97aa6eca by Cheng Shao at 2025-12-08T19:07:33+01:00 ci: update alpine/fedora & add ubsan job This patch updates alpine image to 3.23, fedora image to 43, and adds a `x86_64-linux-fedora43-validate+debug_info+ubsan` job that's run in validate/nightly pipelines to catch undefined behavior in the RTS codebase. - - - - - 5b6a97af by Cheng Shao at 2025-12-08T19:07:33+01:00 rts: fix zero-length VLA undefined behavior in interpretBCO This commit fixes a zero-length VLA undefined behavior in interpretBCO, caught by UBSan: ``` +rts/Interpreter.c:3133:19: runtime variable length array bound evaluates to non-positive value 0 ``` - - - - - 096fd45c by Cheng Shao at 2025-12-08T19:07:33+01:00 rts: fix unaligned ReadSpB in interpretBCO This commit fixes unaligned ReadSpB in interpretBCO, caught by UBSan: ``` +rts/Interpreter.c:2174:64: runtime load of misaligned address 0x004202059dd1 for type 'StgWord', which requires 8 byte alignment ``` To perform proper unaligned read, we define StgUnalignedWord as a type alias of StgWord with aligned(1) attribute, and load StgUnalignedWord instead of StgWord in ReadSpB, so the C compiler is aware that we're not loading with natural alignment. - - - - - f14a8dfc by Cheng Shao at 2025-12-08T19:07:33+01:00 rts: fix signed integer overflow in subword arithmetic in interpretBCO - - - - - 269 changed files: - .gitlab-ci.yml - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py - compile_flags.txt - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/CmmToAsm/AArch64/RegInfo.hs - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/PPC/RegInfo.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Map/Type.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/LlvmConfigCache.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Pipeline/Phases.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Hs/Basic.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Docs.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/Iface/Ext/Ast.hs - + compiler/GHC/Linker/ByteCode.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Prelude/Basic.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Settings.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Error/Codes.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Unique/FM.hs - compiler/GHC/Types/Unique/Set.hs - compiler/GHC/Types/Var/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Info.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - compiler/GHC/Utils/Misc.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/ghc.cabal.in - configure.ac - docs/users_guide/9.16.1-notes.rst - docs/users_guide/conf.py - docs/users_guide/exts/data_kinds.rst - docs/users_guide/exts/explicit_namespaces.rst - docs/users_guide/exts/rank_polymorphism.rst - docs/users_guide/exts/type_families.rst - docs/users_guide/phases.rst - docs/users_guide/using-optimisation.rst - ghc/GHCi/UI.hs - ghc/Main.hs - hadrian/doc/flavours.md - hadrian/src/Builder.hs - hadrian/src/Flavour.hs - hadrian/src/Rules/ToolArgs.hs - hadrian/src/Settings.hs - hadrian/src/Settings/Builders/Ghc.hs - hadrian/src/Settings/Default.hs - hadrian/src/Settings/Warnings.hs - libraries/base/changelog.md - libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/List.hs - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs - libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs - libraries/xhtml - + rts/.ubsan-suppressions - rts/Interpreter.c - rts/eventlog/EventLog.c - rts/include/stg/Types.h - rts/linker/Elf.c - rts/linker/LoadArchive.c - rts/linker/PEi386.c - rts/rts.cabal - testsuite/config/ghc - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/mk/boilerplate.mk - + testsuite/tests/bytecode/T26640.hs - + testsuite/tests/bytecode/T26640.script - + testsuite/tests/bytecode/T26640.stdout - testsuite/tests/bytecode/all.T - + testsuite/tests/cabal/Bytecode.hs - + testsuite/tests/cabal/BytecodeForeign.c - + testsuite/tests/cabal/BytecodeForeign.hs - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/bytecode.pkg - + testsuite/tests/cabal/bytecode.script - + testsuite/tests/cabal/bytecode_foreign.pkg - + testsuite/tests/cabal/bytecode_foreign.script - testsuite/tests/cabal/ghcpkg03.stderr - testsuite/tests/cabal/ghcpkg03.stderr-mingw32 - testsuite/tests/cabal/ghcpkg05.stderr - testsuite/tests/cabal/ghcpkg05.stderr-mingw32 - + testsuite/tests/cabal/pkg_bytecode.stderr - + testsuite/tests/cabal/pkg_bytecode.stdout - + testsuite/tests/cabal/pkg_bytecode_foreign.stderr - + testsuite/tests/cabal/pkg_bytecode_foreign.stdout - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stderr - + testsuite/tests/cabal/pkg_bytecode_with_gbc.stdout - + testsuite/tests/cabal/pkg_bytecode_with_o.stderr - + testsuite/tests/cabal/pkg_bytecode_with_o.stdout - + testsuite/tests/codeGen/should_run/T24016.hs - + testsuite/tests/codeGen/should_run/T24016.stdout - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/driver/T20696/T20696.stderr-ext-interp - testsuite/tests/driver/T20696/all.T - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/driver/bytecode-object/bytecode_object19.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object20.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object21.stderr - + testsuite/tests/driver/bytecode-object/bytecode_object21.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object23.stdout - + testsuite/tests/driver/bytecode-object/bytecode_object24.stdout - testsuite/tests/driver/fat-iface/all.T - + testsuite/tests/driver/fat-iface/fat012.stderr-ext-interp - + testsuite/tests/driver/fat-iface/fat015.stderr-ext-interp - testsuite/tests/driver/j-space/jspace.hs - + testsuite/tests/module/T25901_exp_plain_wc.hs - + testsuite/tests/module/T25901_exp_plain_wc.stderr - + testsuite/tests/module/T25901_imp_plain_wc.hs - + testsuite/tests/module/T25901_imp_plain_wc.stderr - testsuite/tests/module/all.T - + testsuite/tests/rename/should_compile/T25901_exp_1.hs - + testsuite/tests/rename/should_compile/T25901_exp_1_helper.hs - + testsuite/tests/rename/should_compile/T25901_exp_2.hs - + testsuite/tests/rename/should_compile/T25901_exp_2_helper.hs - + testsuite/tests/rename/should_compile/T25901_imp_hq.hs - + testsuite/tests/rename/should_compile/T25901_imp_hu.hs - + testsuite/tests/rename/should_compile/T25901_imp_sq.hs - + testsuite/tests/rename/should_compile/T25901_imp_su.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_1.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_1_helper.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_exp_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_exp_fail_2_helper.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.hs - + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.stderr - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.hs - + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.hs - + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.stderr - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.hs - + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.stderr - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rts/KeepCafsBase.hs - testsuite/tests/rts/all.T - + testsuite/tests/simplCore/should_compile/T26588.hs - + testsuite/tests/simplCore/should_compile/T26589.hs - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/splice-imports/SI07.stderr-ext-interp - testsuite/tests/splice-imports/all.T - + testsuite/tests/th/T26099.hs - + testsuite/tests/th/T26099.stderr - + testsuite/tests/th/T26568.hs - + testsuite/tests/th/T26568.stderr - testsuite/tests/th/all.T - testsuite/tests/unboxedsums/UbxSumUnpackedSize.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.hs - + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr - + testsuite/tests/warnings/should_compile/T25901_helper_1.hs - + testsuite/tests/warnings/should_compile/T25901_helper_2.hs - + testsuite/tests/warnings/should_compile/T25901_helper_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.stderr - + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.hs - + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.stderr - testsuite/tests/warnings/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/ghc-pkg/Main.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs - utils/haddock/cabal.project - utils/haddock/haddock-api/haddock-api.cabal - utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Renderer.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Names.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs - utils/haddock/haddock-api/src/Haddock/Doc.hs - utils/haddock/haddock-api/src/Haddock/Utils.hs - utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs - utils/haddock/html-test/ref/Bug26.html - utils/haddock/html-test/ref/Bug298.html - utils/haddock/html-test/ref/Bug458.html - utils/haddock/html-test/ref/Nesting.html - utils/haddock/html-test/ref/TitledPicture.html - utils/haddock/html-test/ref/Unicode.html - utils/haddock/html-test/ref/Unicode2.html - utils/hpc - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f958e99b9e937ab3cfa40f1db432ea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f958e99b9e937ab3cfa40f1db432ea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mwb-perf-tuning-2] 7 commits: Use ModuleGraph for cache
by Torsten Schmits (＠torsten.schmits) 08 Dec '25

08 Dec '25

Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning-2 at Glasgow Haskell Compiler / GHC Commits: 44e58cbd by Matthew Pickering at 2025-12-08T17:48:09+01:00 Use ModuleGraph for cache - - - - - e24f2f02 by Matthew Pickering at 2025-12-08T17:48:09+01:00 OsPath for Map - - - - - 0a9fd4a6 by Matthew Pickering at 2025-12-08T17:48:09+01:00 Set hpt deps - - - - - 4d5286c1 by Matthew Pickering at 2025-12-08T17:48:09+01:00 HomeUnitMap - - - - - c293535e by Matthew Pickering at 2025-12-08T17:48:09+01:00 Use a name provider map for home packages - - - - - 444ba945 by Torsten Schmits at 2025-12-08T17:48:09+01:00 disable home unit closure check - - - - - afa9ff5f by Torsten Schmits at 2025-12-08T17:48:09+01:00 WIP: unit index - - - - - 26 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + index <- hscUnitIndex <$> getSession + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do then do -- additionally, set checked dflags so we don't lose fixes old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + ue_index <- hscUnitIndex <$> getSession home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv @@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env , ue_eps = ue_eps old_unit_env + , ue_index } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env -> getNamePprCtx :: GhcMonad m => m NamePprCtx getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1474,7 +1478,8 @@ mkNamePprCtxForModule :: ModuleInfo -> m NamePprCtx mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + query <- liftIO $ hscUnitIndexQuery hsc_env + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) ptc = initPromotionTickContext (hsc_dflags hsc_env) return name_ppr_ctx @@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual -renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) +renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual -renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p) +renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'. In @@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + query <- hscUnitIndexQuery hsc_env + res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_tag = 's' + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ @@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -459,6 +460,7 @@ doCorePass pass guts = do dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv + query <- liftIO $ hscUnitIndexQuery hsc_env let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } @@ -471,6 +473,7 @@ doCorePass pass guts = do mkNamePprCtx (initPromotionTickContext dflags) (hsc_unit_env hsc_env) + query rdr_env ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -430,6 +430,7 @@ addUnit u = do logger <- getLogger let dflags0 = hsc_dflags hsc_env let old_unit_env = hsc_unit_env hsc_env + ue_index = hscUnitIndex hsc_env newdbs <- case ue_unit_dbs old_unit_env of Nothing -> panic "addUnit: called too early" Just dbs -> @@ -438,7 +439,7 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env) -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants @@ -453,6 +454,7 @@ addUnit u = do (homeUnitId home_unit) (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_index } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -871,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + query <- liftIO $ hscUnitIndexQuery hsc_env + -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps @@ -883,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname implicit_imports = mkPrelImports modname loc implicit_prelude imps - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -7,6 +7,8 @@ module GHC.Driver.Env , hsc_home_unit , hsc_home_unit_maybe , hsc_units + , hscUnitIndex + , hscUnitIndexQuery , hsc_HPT , hsc_HUE , hsc_HUG @@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_units . hsc_unit_env +hscUnitIndex :: HscEnv -> UnitIndex +hscUnitIndex = ue_index . hsc_unit_env + +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery +hscUnitIndexQuery hsc_env = + unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env) + hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2573,9 +2573,10 @@ hscTidy hsc_env guts = do $! {-# SCC "CoreTidy" #-} tidyProgram opts guts -- post tidy pretty-printing and linting... + query <- hscUnitIndexQuery hsc_env let tidy_rules = md_rules details let all_tidy_binds = cg_binds cgguts - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts) ptc = initPromotionTickContext (hsc_dflags hsc_env) endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -113,6 +113,8 @@ import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar @@ -187,12 +189,13 @@ depanalE excluded_mods allow_dup_roots = do if isEmptyMessages errs then do hsc_env <- getSession + query <- liftIO $ hscUnitIndexQuery hsc_env let one_unit_messages get_mod_errs k hue = do errs <- get_mod_errs unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph - unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph return $ errs `unionMessages` unused_home_mod_err @@ -244,7 +247,7 @@ depanalPartial excluded_mods allow_dup_roots = do liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) (errs, graph_nodes) <- liftIO $ downsweep - hsc_env (mgModSummaries old_graph) + hsc_env (mgModSummaries old_graph) Nothing excluded_mods allow_dup_roots let mod_graph = mkModuleGraph graph_nodes @@ -510,15 +513,15 @@ loadWithCache cache diag_wrapper how_much = do -- actually loaded packages. All the packages, specified on command line, -- but never loaded, are probably unused dependencies. -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages -warnUnusedPackages us dflags mod_graph = +warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages +warnUnusedPackages us query dflags mod_graph = let diag_opts = initDiagOpts dflags home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) -- Only need non-source imports here because SOURCE imports are always HPT loadedPackages = concat $ - mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) + mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs) $ concatMap ms_imps home_mod_sum any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum @@ -1537,6 +1540,10 @@ warnUnnecessarySourceImports sccs = do -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode +moduleGraphNodeMap graph = + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1555,6 +1562,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv downsweep :: HscEnv -> [ModSummary] -- ^ Old summaries + -> Maybe ModuleGraph + -- ^ Existing module graph to reuse cached nodes from -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have @@ -1564,10 +1573,10 @@ downsweep :: HscEnv -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) new <- rootSummariesParallel n_jobs hsc_env summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new where summary = getRootSummary excl_mods old_summary_map @@ -1576,22 +1585,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map :: M.Map (UnitId, OsPath) ModSummary old_summary_map = - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries] downsweep_imports :: HscEnv - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary + -> Maybe ModuleGraph -> [ModuleName] -> Bool -> ([(UnitId, DriverMessages)], [ModSummary]) -> IO ([DriverMessages], [ModuleGraphNode]) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk) = do let root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) + let done0 = maybe M.empty moduleGraphNodeMap old_graph + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1601,7 +1611,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) all_nodes = downsweep_nodes ++ unit_nodes all_errs = all_root_errs ++ downsweep_errs ++ other_errs - all_root_errs = closure_errs ++ map snd root_errs + all_root_errs = map snd root_errs -- if we have been passed -fno-code, we enable code generation -- for dependencies of modules that have -XTemplateHaskell, @@ -1721,7 +1731,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro getRootSummary :: [ModuleName] -> - M.Map (UnitId, FilePath) ModSummary -> + M.Map (UnitId, OsPath) ModSummary -> HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary) @@ -2067,7 +2077,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> M.Map (UnitId, OsPath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -2076,7 +2086,7 @@ summariseFile summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries = do let location = ms_location $ old_summary @@ -2097,6 +2107,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + src_fn_os = OsPath.unsafeEncodeUtf src_fn -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -2186,7 +2197,7 @@ data SummariseResult = summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -2247,7 +2258,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Right ms -> FoundHome ms new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the @@ -2258,6 +2269,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Nothing -> checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h | otherwise = new_summary loc mod src_fn h + where + src_fn_os = OsPath.unsafeEncodeUtf src_fn new_summary :: ModLocation -> Module @@ -2385,7 +2398,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) let pi_srcimps = rn_imps pi_srcimps' let pi_theimps = rn_imps pi_theimps' ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do buf <- hGetStringBuffer input_fn + query <- hscUnitIndexQuery hsc_env let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn)) eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -149,7 +149,8 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env ptc = initPromotionTickContext (hsc_dflags hsc_env) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -89,6 +89,7 @@ import GHC.Data.FastString import GHC.Unit.Env import GHC.Unit.External +import GHC.Unit.State (UnitIndexQuery) import GHC.Unit.Module import GHC.Unit.Module.ModGuts @@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env ++ eps_complete_matches eps -- from imports -- re-use existing next_wrapper_num to ensure uniqueness next_wrapper_num_var = tcg_next_wrapper_num tcg_env - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num_var complete_matches } @@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; next_wrapper_num <- newIORef emptyModuleEnv ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env + ; query <- liftIO $ hscUnitIndexQuery hsc_env ; let unit_env = hsc_unit_env hsc_env type_env = typeEnvFromEntities ids tycons patsyns fam_insts ptc = initPromotionTickContext (hsc_dflags hsc_env) @@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds binds - envs = mkDsEnvs unit_env this_mod rdr_env type_env + envs = mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside @@ -342,12 +345,12 @@ initTcDsForSolver thing_inside Just ret -> pure ret Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } -mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv +mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> PromotionTickContext -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var +mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" -- Failing tests here are `ghci` and `T11985` if you get this wrong. @@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) + query <- liftIO $ hscUnitIndexQuery hsc_env + res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return $ NeedsRecompile recomp Right es -> do ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -355,7 +355,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (Set.toList (homeUnitDepends (hsc_units hsc'))) pls'' <- loadCmdLineLibs'' interp hsc' pls' return $ (Set.insert uid done', pls'') ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -27,6 +27,7 @@ module GHC.Rename.Names ( getMinimalImports, printMinimalImports, renamePkgQual, renameRawPkgQual, + hscRenamePkgQual, hscRenameRawPkgQual, classifyGREs, ImportDeclUsage, ) where @@ -337,7 +338,8 @@ rnImportDecl this_mod hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -447,14 +449,14 @@ rnImportDecl this_mod -- | Rename raw package imports -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual -renameRawPkgQual unit_env mn = \case +renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env query mn = \case NoRawPkgQual -> NoPkgQual - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) + RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p)) -- | Rename raw package imports -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual -renamePkgQual unit_env mn mb_pkg = case mb_pkg of +renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual +renamePkgQual unit_env query mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs | Just uid <- homeUnitId <$> ue_homeUnit unit_env @@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names -> ThisPkg uid - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) + | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs) -> OtherPkg uid | otherwise @@ -472,13 +474,35 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later... where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + home_names = + [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env))) + | uid <- S.toList hpt_deps + ] units = ue_units unit_env - hpt_deps :: [UnitId] + hpt_deps :: S.Set UnitId hpt_deps = homeUnitDepends units +hscRenameRawPkgQual :: + MonadIO m => + HscEnv -> + ModuleName -> + RawPkgQual -> + m PkgQual +hscRenameRawPkgQual hsc_env name raw = do + query <- liftIO $ hscUnitIndexQuery hsc_env + pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw) + +hscRenamePkgQual :: + MonadIO m => + HscEnv -> + ModuleName -> + Maybe FastString -> + m PkgQual +hscRenamePkgQual hsc_env name package = do + query <- liftIO $ hscUnitIndexQuery hsc_env + pure (renamePkgQual (hsc_unit_env hsc_env) query name package) -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) import GHC.Unit import GHC.Unit.Env +import GHC.Unit.State (UnitIndexQuery) import GHC.Core.FamInstEnv import GHC.Core.InstEnv @@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) ] -- | Get the NamePprCtx function based on the flags and this InteractiveContext -icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx -icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) +icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx +icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt) where ptc = initPromotionTickContext (ic_dflags ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let unit_state = ue_units unit_env let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name + query <- hscUnitIndexQuery hsc_env + found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum ; when (notNull prel_imports) $ do addDiagnostic TcRnImplicitImportOfPrelude + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = - ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) + ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl) , reLoc $ ideclName idecl) } ; raw_sig_imports <- liftIO @@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside (loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg) + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) - (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) + IIDecl i -> do + qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i) + getOrphans (unLoc (ideclName i)) qual ; let imports = emptyImportAvails { imp_orphs = orphs } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -869,7 +869,8 @@ getNamePprCtx = do { ptc <- initPromotionTickContext <$> getDynFlags ; rdr_env <- getGlobalRdrEnv ; hsc_env <- getTopEnv - ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env } + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () ===================================== compiler/GHC/Types/Name/Ppr.hs ===================================== @@ -13,6 +13,7 @@ import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env +import GHC.Unit.State (UnitIndexQuery) import GHC.Types.Name import GHC.Types.Name.Reader @@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx -mkNamePprCtx ptc unit_env env +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx +mkNamePprCtx ptc unit_env index env = QueryQualify (mkQualName env) - (mkQualModule unit_state home_unit) + (mkQualModule unit_state index home_unit) (mkQualPackage unit_state) (mkPromTick ptc env) where @@ -206,8 +207,8 @@ Side note (int-index): -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule -mkQualModule unit_state mhome_unit mod +mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule +mkQualModule unit_state index mhome_unit mod | Just home_unit <- mhome_unit , isHomeModule home_unit mod = False @@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod = False | otherwise = True - where lookup = lookupModuleInAllUnits unit_state (moduleName mod) + where lookup = lookupModuleInAllUnits unit_state index (moduleName mod) -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -100,6 +100,8 @@ data UnitEnv = UnitEnv , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + + , ue_index :: !UnitIndex } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache + ue_index <- newUnitIndex return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever + , ue_index } -- | Get home-unit @@ -138,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) loop acc (uid:uids) | uid `Set.member` acc = loop acc uids | otherwise = - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) + let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))) in loop (Set.insert uid acc) (hue ++ uids) ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -67,8 +67,9 @@ import Control.Monad import Data.Time import qualified Data.Map as M import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery ) import GHC.Driver.Config.Finder +import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap) import qualified Data.Set as Set type FileExt = String -- Filename extension @@ -161,28 +162,36 @@ findImportedModule hsc_env mod pkg_qual = dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags in do - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual + query <- hscUnitIndexQuery hsc_env + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv + -> UnitIndexQuery + -> ModuleNameHomeMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where + (complete_units, module_name_map) = home_module_map + module_home_units = M.findWithDefault Set.empty mod_name module_name_map + current_unit_id = homeUnitId <$> mhome_unit all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + Nothing -> other_fopts_list + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list + other_fopts_map = M.fromList other_fopts_list home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -193,7 +202,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | mod_name `Set.member` finder_reexportedModules opts = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual | mod_name `Set.member` finder_hiddenModules opts = return (mkHomeHidden uid) | otherwise = @@ -202,32 +211,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list) - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg unqual_import = any_home_import `orIfNotFound` - findExposedPackageModule fc fopts units mod_name NoPkgQual + findExposedPackageModule fc fopts units query mod_name NoPkgQual units = case mhome_unit of Nothing -> ue_units ue Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] + hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + dep_providers = Set.intersection module_home_units hpt_deps + known_other_uids = + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id + in Set.toList providers + unknown_units = + let candidates = Set.difference hpt_deps complete_units + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + in Set.toList (Set.difference candidates excluded) + other_home_uids = known_other_uids ++ unknown_units + other_fopts_list = + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) + | uid <- other_home_uids + ] -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModule fc fopts units query (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` - findExposedPluginPackageModule fc fopts units mod_name -findPluginModule fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name + findExposedPluginPackageModule fc fopts units query mod_name +findPluginModule fc fopts units query Nothing mod_name = + findExposedPluginPackageModule fc fopts units query mod_name -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out @@ -283,15 +304,15 @@ homeSearchCache fc home_unit mod_name do_this = do let mod = mkModule home_unit mod_name modLocationCache fc mod do_this -findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult -findExposedPackageModule fc fopts units mod_name mb_pkg = +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult +findExposedPackageModule fc fopts units query mod_name mb_pkg = findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + $ lookupModuleWithSuggestions units query mod_name mb_pkg -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult -findExposedPluginPackageModule fc fopts units mod_name = +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult +findExposedPluginPackageModule fc fopts units query mod_name = findLookupResult fc fopts - $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual + $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult findLookupResult fc fopts r = case r of ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph , mgModSummaries , mgModSummaries' , mgLookupModule + , ModuleNameHomeMap + , mgHomeModuleMap , showModMsg , moduleGraphNodeModule , moduleGraphNodeModSum @@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where -- check that the module and its hs-boot agree. -- -- The graph is not necessarily stored in topologically-sorted order. Use +type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId)) + -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode] , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) -- A cached transitive dependency calculation so that a lot of work is not -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances) + , mg_home_map :: ModuleNameHomeMap + -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete. } -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + { mg_mss = new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps (f ms) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -177,11 +187,27 @@ unionMG a b = in ModuleGraph { mg_mss = new_mss , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap +mkHomeModuleMap nodes = + (complete_units, provider_map) + where + provider_map = + Map.fromListWith Set.union + [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + | ModuleNode _ ms <- nodes + ] + complete_units = + Set.fromList + [ ms_unitid ms + | ModuleNode _ ms <- nodes + ] + mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] @@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap +mgHomeModuleMap = mg_home_map + emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty) isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms = @@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms = -- not an element of the ModuleGraph. extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph extendMG ModuleGraph{..} deps ms = ModuleGraph - { mg_mss = ModuleNode deps ms : mg_mss - , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = ModuleNode deps ms : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1,6 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-} -- | Unit manipulation module GHC.Unit.State ( @@ -49,6 +49,15 @@ module GHC.Unit.State ( closeUnitDeps', mayThrowUnitErr, + UnitConfig (..), + UnitIndex (..), + UnitIndexQuery (..), + UnitVisibility (..), + VisibilityMap, + ModuleNameProvidersMap, + newUnitIndex, + unitIndexQuery, + -- * Module hole substitution ShHoleSubst, renameHoleUnit, @@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set import GHC.LanguageExtensions import Control.Applicative +import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef (IORef, newIORef, readIORef) -- --------------------------------------------------------------------------- -- The Unit state @@ -458,7 +469,7 @@ data UnitState = UnitState { -- -Wunused-packages warning. explicitUnits :: [(Unit, Maybe PackageArg)], - homeUnitDepends :: [UnitId], + homeUnitDepends :: Set UnitId, -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want @@ -493,7 +504,7 @@ emptyUnitState = UnitState { unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], - homeUnitDepends = [], + homeUnitDepends = Set.empty, moduleNameProvidersMap = emptyUniqMap, pluginModuleNameProvidersMap = emptyUniqMap, requirementContext = emptyUniqMap, @@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) -- | Find the UnitId which an import qualified by a package import comes from. -- Compared to 'lookupPackageName', this function correctly accounts for visibility, -- renaming and thinning. -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId -resolvePackageImport unit_st mn pn = do +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId +resolvePackageImport unit_st query mn pn = do -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc) - providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn + providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False -- 2. Get the UnitIds of the candidates let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers -- 3. Get the package names of the candidates @@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- '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 -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs home_units = do +initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags index cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () (unit_state,dbs) <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) @@ -1021,7 +1032,7 @@ 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)) + then Left (filter (matches . fst) (nonDetEltsUniqMap unusable)) else Right (sortByPreference prec_map ps, rest) -- | Rename a 'UnitInfo' according to some module instantiation. @@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> UnitId -> UnitConfig + -> UnitIndex -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState logger cfg = do +mkUnitState logger unit cfg index = do {- Plan. @@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do -- if databases have not been provided, read the database flags raw_dbs <- case unitConfigDBCache cfg of - Nothing -> readUnitDatabases logger cfg + Nothing -> index.readDatabases logger unit cfg Just dbs -> return dbs - -- distrust all units if the flag is set - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs - | otherwise = raw_dbs - - -- This, and the other reverse's that you will see, are due to the fact that -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. @@ -1561,169 +1568,17 @@ mkUnitState logger cfg = do let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags - -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases logger dbs - - -- Now that we've merged everything together, prune out unusable - -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 - - reportCycles logger sccs - reportUnusable logger unusable - - -- Apply trust flags (these flags apply regardless of whether - -- or not packages are visible or not) - pkgs1 <- mayThrowUnitErr - $ foldM (applyTrustFlag prec_map unusable) - (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) - let prelim_pkg_db = mkUnitInfoMap pkgs1 - - -- - -- Calculate the initial set of units from package databases, prior to any package flags. - -- - -- Conceptually, we select the latest versions of all valid (not unusable) *packages* - -- (not units). This is empty if we have -hide-all-packages. - -- - -- Then we create an initial visibility map with default visibilities for all - -- exposed, definite units which belong to the latest valid packages. - -- - let preferLater unit unit' = - case compareByPreference prec_map unit unit' of - GT -> unit - _ -> unit' - addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit - -- This is the set of maximally preferable packages. In fact, it is a set of - -- most preferable *units* keyed by package name, which act as stand-ins in - -- for "a package in a database". We use units here because we don't have - -- "a package in a database" as a type currently. - mostPreferablePackageReps = if unitConfigHideAll cfg - then emptyUDFM - else foldl' addIfMorePreferable emptyUDFM pkgs1 - -- When exposing units, we want to consider all of those in the most preferable - -- packages. We can implement that by looking for units that are equi-preferable - -- with the most preferable unit for package. Being equi-preferable means that - -- they must be in the same database, with the same version, and the same package name. - -- - -- We must take care to consider all these units and not just the most - -- preferable one, otherwise we can end up with problems like #16228. - mostPreferable u = - case lookupUDFM mostPreferablePackageReps (fsPackageName u) of - Nothing -> False - Just u' -> compareByPreference prec_map u u' == EQ - vis_map1 = foldl' (\vm p -> - -- Note: we NEVER expose indefinite packages by - -- default, because it's almost assuredly not - -- what you want (no mix-in linking has occurred). - if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p - then addToUniqMap vm (mkUnit p) - UnitVisibility { - uv_expose_all = True, - uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), - uv_requirements = emptyUniqMap, - uv_explicit = Nothing - } - else vm) - emptyUniqMap pkgs1 - - -- - -- Compute a visibility map according to the command-line flags (-package, - -- -hide-package). This needs to know about the unusable packages, since if a - -- user tries to enable an unusable package, we should let them know. - -- - vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable - (unitConfigHideAll cfg) pkgs1) - vis_map1 other_flags - - -- - -- Sort out which packages are wired in. This has to be done last, since - -- it modifies the unit ids of wired in packages, but when we process - -- package arguments we need to key against the old versions. - -- - (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 - let pkg_db = mkUnitInfoMap pkgs2 - - -- Update the visibility map, so we treat wired packages as visible. - let vis_map = updateVisibilityMap wired_map vis_map2 - - let hide_plugin_pkgs = unitConfigHideAllPlugins cfg - plugin_vis_map <- - case unitConfigFlagsPlugins cfg of - -- common case; try to share the old vis_map - [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return emptyUniqMap - _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = emptyUniqMap - -- Use the vis_map PRIOR to wired in, - -- because otherwise applyPackageFlag - -- won't work. - | otherwise = vis_map2 - plugin_vis_map2 - <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable - hide_plugin_pkgs pkgs1) - plugin_vis_map1 - (reverse (unitConfigFlagsPlugins cfg)) - -- Updating based on wired in packages is mostly - -- good hygiene, because it won't matter: no wired in - -- package has a compiler plugin. - -- TODO: If a wired in package had a compiler plugin, - -- and you tried to pick different wired in packages - -- with the plugin flags and the normal flags... what - -- would happen? I don't know! But this doesn't seem - -- likely to actually happen. - return (updateVisibilityMap wired_map plugin_vis_map2) - - let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) - | p <- pkgs2 - ] - -- The explicitUnits accurately reflects the set of units we have turned - -- on; as such, it also is the only way one can come up with requirements. - -- The requirement context is directly based off of this: we simply - -- look for nested unit IDs that are directly fed holes: the requirements - -- of those units are precisely the ones we need to track - let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] - req_ctx = mapUniqMap (Set.toList) - $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) - - - -- - -- Here we build up a set of the packages mentioned in -package - -- flags on the command line; these are called the "preload" - -- packages. we link these packages in eagerly. The preload set - -- should contain at least rts & base, which is why we pretend that - -- the command line contains -package rts & -package base. - -- - -- NB: preload IS important even for type-checking, because we - -- need the correct include path to be set. - -- - let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) - - -- add default preload units if they can be found in the db - basicLinkedUnits = fmap (RealUnit . Definite) - $ filter (flip elemUniqMap pkg_db) - $ unitConfigAutoLink cfg - preload3 = ordNub $ (basicLinkedUnits ++ preload1) - - -- Close the preload packages with their dependencies - dep_preload <- mayThrowUnitErr - $ closeUnitDeps pkg_db - $ zip (map toUnitId preload3) (repeat Nothing) - - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map - mod_map2 = mkUnusableModuleNameProvidersMap unusable - mod_map = mod_map2 `plusUniqMap` mod_map1 + (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags -- Force the result to avoid leaking input parameters let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet - , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , moduleNameProvidersMap + , pluginModuleNameProvidersMap , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1896,6 +1751,263 @@ addListTo = foldl' merge mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin mkModMap pkg mod = unitUniqMap (mkModule pkg mod) +-- ----------------------------------------------------------------------------- +-- Index + +data UnitIndexQuery = + UnitIndexQuery { + findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin), + index_all :: UnitState -> ModuleNameProvidersMap + } + +data UnitIndex = + UnitIndex { + query :: UnitId -> IO UnitIndexQuery, + readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId], + update :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO ( + ModuleNameProvidersMap, + ModuleNameProvidersMap, + UnitInfoMap, + [(Unit, Maybe PackageArg)], + [UnitId], + UniqMap ModuleName [InstantiatedModule], + UniqFM PackageName UnitId, + WiringMap + ) + } + +unitIndexQuery :: + MonadIO m => + UnitId -> + UnitIndex -> + m UnitIndexQuery +unitIndexQuery unit index = liftIO (index.query unit) + +data UnitIndexBackend = + UnitIndexBackend { + moduleNameProviders :: !ModuleNameProvidersMap, + pluginModuleNameProviders :: !ModuleNameProvidersMap + } + +newUnitIndexBackend :: UnitIndexBackend +newUnitIndexBackend = + UnitIndexBackend { + moduleNameProviders = mempty, + pluginModuleNameProviders = mempty + } + +queryFindOriginDefault :: + UnitIndexBackend -> + UnitState -> + ModuleName -> + Bool -> + Maybe (UniqMap Module ModuleOrigin) +queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins = + lookupUniqMap source name + where + source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap + +newUnitIndexQuery :: + MonadIO m => + IORef UnitIndexBackend -> + UnitId -> + m UnitIndexQuery +newUnitIndexQuery ref _ = do + state <- liftIO $ readIORef ref + pure UnitIndexQuery { + findOrigin = queryFindOriginDefault state, + index_all = \ s -> s.moduleNameProvidersMap + } + +updateIndexDefault :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap) +updateIndexDefault logger _ cfg raw_dbs other_flags = do + + -- distrust all units if the flag is set + let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } + dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs + | otherwise = raw_dbs + + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases logger dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + + reportCycles logger sccs + reportUnusable logger unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable) + (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + let prelim_pkg_db = mkUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if unitConfigHideAll cfg + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + then addToUniqMap vm (mkUnit p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = emptyUniqMap, + uv_explicit = Nothing + } + else vm) + emptyUniqMap pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + (unitConfigHideAll cfg) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 + let pkg_db = mkUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = unitConfigHideAllPlugins cfg + plugin_vis_map <- + case unitConfigFlagsPlugins cfg of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return emptyUniqMap + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = emptyUniqMap + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + hide_plugin_pkgs pkgs1) + plugin_vis_map1 + (reverse (unitConfigFlagsPlugins cfg)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) + | p <- pkgs2 + ] + -- The explicitUnits accurately reflects the set of units we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] + req_ctx = mapUniqMap (Set.toList) + $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) + + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) + + -- add default preload units if they can be found in the db + basicLinkedUnits = fmap (RealUnit . Definite) + $ filter (flip elemUniqMap pkg_db) + $ unitConfigAutoLink cfg + preload3 = ordNub $ (basicLinkedUnits ++ preload1) + + -- Close the preload packages with their dependencies + dep_preload <- mayThrowUnitErr + $ closeUnitDeps pkg_db + $ zip (map toUnitId preload3) (repeat Nothing) + + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = mod_map2 `plusUniqMap` mod_map1 + pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) + +readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId] +readDatabasesDefault logger _ cfg = + readUnitDatabases logger cfg + +newUnitIndex :: MonadIO m => m UnitIndex +newUnitIndex = do + ref <- liftIO $ newIORef newUnitIndexBackend + pure UnitIndex { + query = newUnitIndexQuery ref, + readDatabases = readDatabasesDefault, + update = updateIndexDefault + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -1903,10 +2015,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod) -- | Takes a 'ModuleName', and if the module is in any package returns -- list of modules which take that name. lookupModuleInAllUnits :: UnitState + -> UnitIndexQuery -> ModuleName -> [(Module, UnitInfo)] -lookupModuleInAllUnits pkgs m - = case lookupModuleWithSuggestions pkgs m NoPkgQual of +lookupModuleInAllUnits pkgs query m + = case lookupModuleWithSuggestions pkgs query m NoPkgQual of LookupFound a b -> [(a,fst b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs @@ -1933,18 +2046,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin | SuggestHidden ModuleName Module ModuleOrigin lookupModuleWithSuggestions :: UnitState + -> UnitIndexQuery -> ModuleName -> PkgQual -> LookupResult -lookupModuleWithSuggestions pkgs - = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) +lookupModuleWithSuggestions pkgs query name + = lookupModuleWithSuggestions' pkgs query name False -- | The package which the module **appears** to come from, this could be -- the one which reexports the module from it's original package. This function -- is currently only used for -Wunused-packages -lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo] -lookupModulePackage pkgs mn mfs = - case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of +lookupModulePackage :: + UnitState -> + UnitIndexQuery -> + ModuleName -> + PkgQual -> + Maybe [UnitInfo] +lookupModulePackage pkgs query mn mfs = + case lookupModuleWithSuggestions' pkgs query mn False mfs of LookupFound _ (orig_unit, origin) -> case origin of ModOrigin {fromOrigUnit, fromExposedReexport} -> @@ -1960,19 +2079,21 @@ lookupModulePackage pkgs mn mfs = _ -> Nothing lookupPluginModuleWithSuggestions :: UnitState + -> UnitIndexQuery -> ModuleName -> PkgQual -> LookupResult -lookupPluginModuleWithSuggestions pkgs - = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs) +lookupPluginModuleWithSuggestions pkgs query name + = lookupModuleWithSuggestions' pkgs query name True lookupModuleWithSuggestions' :: UnitState - -> ModuleNameProvidersMap + -> UnitIndexQuery -> ModuleName + -> Bool -> PkgQual -> LookupResult -lookupModuleWithSuggestions' pkgs mod_map m mb_pn - = case lookupUniqMap mod_map m of +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn + = case query.findOrigin pkgs m onlyPlugins of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of @@ -2033,16 +2154,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) + | (m, e) <- nonDetUniqMapToList (query.index_all pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) ] getSuggestion name (mod, origin) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin -listVisibleModuleNames :: UnitState -> [ModuleName] -listVisibleModuleNames state = - map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) +listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName] +listVisibleModuleNames unit_state query = + map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state))) where visible (_, ms) = anyUniqMap originVisible ms -- | Takes a list of UnitIds (and their "parent" dependency, used for error ===================================== ghc/GHCi/UI.hs ===================================== @@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession - let pkg_mods = allVisibleModules (hsc_units hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do hsc_env <- GHC.getSession + query <- liftIO $ hscUnitIndexQuery hsc_env modules <- case m of Just '-' -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allVisibleModules (hsc_units hsc_env) + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor -- | Return a list of visible module names for autocompletion. -- (NB: exposed != visible) -allVisibleModules :: UnitState -> [ModuleName] -allVisibleModules unit_state = listVisibleModuleNames unit_state +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName] +allVisibleModules us query = listVisibleModuleNames us query completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do where mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) = - withSession $ \ hsc_env -> + withSession $ \ hsc_env -> do + query <- liftIO $ hscUnitIndexQuery hsc_env let unit_env = hsc_unit_env hsc_env ptc = initPromotionTickContext dflags - in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env + return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do ===================================== ghc/Main.hs ===================================== @@ -844,7 +844,8 @@ initMulti unitArgsFiles = do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + index = hscUnitIndex hsc_env + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure $ HomeUnitEnv @@ -859,7 +860,7 @@ initMulti unitArgsFiles = do let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} } GHC.setSession final_hsc_env @@ -892,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () checkUnitCycles dflags graph = processSCCs sccs where mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId - mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue))) nodes = map mkNode (unitEnv_elts graph) sccs = stronglyConnCompFromEdgedVerticesOrd nodes ===================================== testsuite/tests/ghc-api/downsweep/OldModLocation.hs ===================================== @@ -47,13 +47,13 @@ main = do liftIO $ do - _emss <- downsweep hsc_env [] [] False + _emss <- downsweep hsc_env [] Nothing [] False flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - (_, nodes) <- downsweep hsc_env [] [] False + (_, nodes) <- downsweep hsc_env [] Nothing [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -168,7 +168,7 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - (_, nodes) <- liftIO $ downsweep hsc_env [] [] False + (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False it label $ cnd (mapMaybe moduleGraphNodeModSum nodes) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/735dc6a73e0f3f87f56e54db7e5fd3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/735dc6a73e0f3f87f56e54db7e5fd3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] 7 commits: Use ModuleGraph for cache
by Torsten Schmits (＠torsten.schmits) 08 Dec '25

08 Dec '25

Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC Commits: c7172262 by Matthew Pickering at 2025-12-08T17:49:52+01:00 Use ModuleGraph for cache - - - - - d8b91d4f by Matthew Pickering at 2025-12-08T17:49:52+01:00 OsPath for Map - - - - - 2512ed99 by Matthew Pickering at 2025-12-08T17:49:52+01:00 Set hpt deps - - - - - d8783981 by Matthew Pickering at 2025-12-08T17:49:52+01:00 HomeUnitMap - - - - - a67d2eee by Matthew Pickering at 2025-12-08T17:49:52+01:00 Use a name provider map for home packages - - - - - 02250a35 by Torsten Schmits at 2025-12-08T17:49:52+01:00 disable home unit closure check - - - - - b31c9d52 by Torsten Schmits at 2025-12-08T17:49:52+01:00 WIP: unit index - - - - - 26 changed files: - compiler/GHC.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Ppr.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Monad.hs - ghc/Main.hs - testsuite/tests/ghc-api/downsweep/OldModLocation.hs - testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + index <- hscUnitIndex <$> getSession + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = @@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do then do -- additionally, set checked dflags so we don't lose fixes old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + ue_index <- hscUnitIndex <$> getSession home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv @@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv @@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env , ue_eps = ue_eps old_unit_env + , ue_index } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env -> getNamePprCtx :: GhcMonad m => m NamePprCtx getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1474,7 +1478,8 @@ mkNamePprCtxForModule :: ModuleInfo -> m NamePprCtx mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + query <- liftIO $ hscUnitIndexQuery hsc_env + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) ptc = initPromotionTickContext (hsc_dflags hsc_env) return name_ppr_ctx @@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual -renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) +renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual -renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p) +renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p -- | Like 'findModule', but differs slightly when the module refers to -- a source file, and the file has not been loaded via 'load'. In @@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let units = hsc_units hsc_env let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags - res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + query <- hscUnitIndexQuery hsc_env + res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Core/Opt/Pipeline.hs ===================================== @@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_rdr_env = rdr_env }) = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_tag = 's' + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod name_ppr_ctx loc $ @@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -459,6 +460,7 @@ doCorePass pass guts = do dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv + query <- liftIO $ hscUnitIndexQuery hsc_env let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } @@ -471,6 +473,7 @@ doCorePass pass guts = do mkNamePprCtx (initPromotionTickContext dflags) (hsc_unit_env hsc_env) + query rdr_env ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -429,6 +429,7 @@ addUnit u = do logger <- getLogger let dflags0 = hsc_dflags hsc_env let old_unit_env = hsc_unit_env hsc_env + ue_index = hscUnitIndex hsc_env newdbs <- case ue_unit_dbs old_unit_env of Nothing -> panic "addUnit: called too early" Just dbs -> @@ -437,7 +438,7 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env) -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants @@ -452,6 +453,7 @@ addUnit u = do (homeUnitId home_unit) (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_index } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + query <- liftIO $ hscUnitIndexQuery hsc_env + -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps @@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname implicit_imports = mkPrelImports modname loc implicit_prelude imps - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -7,6 +7,8 @@ module GHC.Driver.Env , hsc_home_unit , hsc_home_unit_maybe , hsc_units + , hscUnitIndex + , hscUnitIndexQuery , hsc_HPT , hsc_HUE , hsc_HUG @@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_units . hsc_unit_env +hscUnitIndex :: HscEnv -> UnitIndex +hscUnitIndex = ue_index . hsc_unit_env + +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery +hscUnitIndexQuery hsc_env = + unitIndexQuery (hscActiveUnitId hsc_env) (hscUnitIndex hsc_env) + hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do $! {-# SCC "CoreTidy" #-} tidyProgram opts guts -- post tidy pretty-printing and linting... + query <- hscUnitIndexQuery hsc_env let tidy_rules = md_rules details let all_tidy_binds = cg_binds cgguts - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts) ptc = initPromotionTickContext (hsc_dflags hsc_env) endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -114,6 +114,8 @@ import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Data.OsPath (OsPath) +import qualified GHC.Data.OsPath as OsPath import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar @@ -188,12 +190,13 @@ depanalE excluded_mods allow_dup_roots = do if isEmptyMessages errs then do hsc_env <- getSession + query <- liftIO $ hscUnitIndexQuery hsc_env let one_unit_messages get_mod_errs k hue = do errs <- get_mod_errs unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph - unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph return $ errs `unionMessages` unused_home_mod_err @@ -245,7 +248,7 @@ depanalPartial excluded_mods allow_dup_roots = do liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) (errs, graph_nodes) <- liftIO $ downsweep - hsc_env (mgModSummaries old_graph) + hsc_env (mgModSummaries old_graph) Nothing excluded_mods allow_dup_roots let mod_graph = mkModuleGraph graph_nodes @@ -511,15 +514,15 @@ loadWithCache cache diag_wrapper how_much = do -- actually loaded packages. All the packages, specified on command line, -- but never loaded, are probably unused dependencies. -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages -warnUnusedPackages us dflags mod_graph = +warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages +warnUnusedPackages us query dflags mod_graph = let diag_opts = initDiagOpts dflags home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) -- Only need non-source imports here because SOURCE imports are always HPT loadedPackages = concat $ - mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) + mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs) $ concatMap ms_imps home_mod_sum any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum @@ -1539,6 +1542,10 @@ warnUnnecessarySourceImports sccs = do -- an import of this module mean. type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode +moduleGraphNodeMap graph = + M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph] + ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis) @@ -1557,6 +1564,8 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv downsweep :: HscEnv -> [ModSummary] -- ^ Old summaries + -> Maybe ModuleGraph + -- ^ Existing module graph to reuse cached nodes from -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have @@ -1566,10 +1575,10 @@ downsweep :: HscEnv -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots = do +downsweep hsc_env old_summaries old_graph excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) new <- rootSummariesParallel n_jobs hsc_env summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + downsweep_imports hsc_env old_summary_map old_graph excl_mods allow_dup_roots new where summary = getRootSummary excl_mods old_summary_map @@ -1578,22 +1587,23 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = do -- file was used in. -- Reuse these if we can because the most expensive part of downsweep is -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map :: M.Map (UnitId, OsPath) ModSummary old_summary_map = - M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + M.fromList [((ms_unitid ms, OsPath.unsafeEncodeUtf (msHsFilePath ms)), ms) | ms <- old_summaries] downsweep_imports :: HscEnv - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary + -> Maybe ModuleGraph -> [ModuleName] -> Bool -> ([(UnitId, DriverMessages)], [ModSummary]) -> IO ([DriverMessages], [ModuleGraphNode]) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) +downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (root_errs, rootSummariesOk) = do let root_map = mkRootMap rootSummariesOk checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) + let done0 = maybe M.empty moduleGraphNodeMap old_graph + (deps, map0) <- loopSummaries rootSummariesOk (done0, root_map) let unit_env = hsc_unit_env hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1603,7 +1613,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) all_nodes = downsweep_nodes ++ unit_nodes all_errs = all_root_errs ++ downsweep_errs ++ other_errs - all_root_errs = closure_errs ++ map snd root_errs + all_root_errs = map snd root_errs -- if we have been passed -fno-code, we enable code generation -- for dependencies of modules that have -XTemplateHaskell, @@ -1723,7 +1733,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro getRootSummary :: [ModuleName] -> - M.Map (UnitId, FilePath) ModSummary -> + M.Map (UnitId, OsPath) ModSummary -> HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary) @@ -2069,7 +2079,7 @@ mkRootMap summaries = Map.fromListWith (flip (++)) summariseFile :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> M.Map (UnitId, OsPath) ModSummary -- old summaries -> FilePath -- source file name -> Maybe Phase -- start phase -> Maybe (StringBuffer,UTCTime) @@ -2078,7 +2088,7 @@ summariseFile summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn_os) old_summaries = do let location = ms_location $ old_summary @@ -2099,6 +2109,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf where -- change the main active unit so all operations happen relative to the given unit hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + src_fn_os = OsPath.unsafeEncodeUtf src_fn -- src_fn does not necessarily exist on the filesystem, so we need to -- check what kind of target we are dealing with get_src_hash = case maybe_buf of @@ -2188,7 +2199,7 @@ data SummariseResult = summariseModule :: HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary + -> M.Map (UnitId, OsPath) ModSummary -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised @@ -2249,7 +2260,7 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Right ms -> FoundHome ms new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn_os)) old_summary_map = -- check the hash on the source file, and -- return the cached summary if it hasn't changed. If the @@ -2260,6 +2271,8 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p Nothing -> checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h | otherwise = new_summary loc mod src_fn h + where + src_fn_os = OsPath.unsafeEncodeUtf src_fn new_summary :: ModLocation -> Module @@ -2387,7 +2400,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) let pi_srcimps = rn_imps pi_srcimps' let pi_theimps = rn_imps pi_theimps' ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do buf <- hGetStringBuffer input_fn + query <- hscUnitIndexQuery hsc_env let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn)) eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -149,7 +149,8 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env ptc = initPromotionTickContext (hsc_dflags hsc_env) - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ; query <- hscUnitIndexQuery hsc_env + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -89,6 +89,7 @@ import GHC.Data.FastString import GHC.Unit.Env import GHC.Unit.External +import GHC.Unit.State (UnitIndexQuery) import GHC.Unit.Module import GHC.Unit.Module.ModGuts @@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env ++ eps_complete_matches eps -- from imports -- re-use existing next_wrapper_num to ensure uniqueness next_wrapper_num_var = tcg_next_wrapper_num tcg_env - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num_var complete_matches } @@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; next_wrapper_num <- newIORef emptyModuleEnv ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env + ; query <- liftIO $ hscUnitIndexQuery hsc_env ; let unit_env = hsc_unit_env hsc_env type_env = typeEnvFromEntities ids tycons patsyns fam_insts ptc = initPromotionTickContext (hsc_dflags hsc_env) @@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds bindsToIds (Rec binds) = map fst binds ids = concatMap bindsToIds binds - envs = mkDsEnvs unit_env this_mod rdr_env type_env + envs = mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside @@ -342,12 +345,12 @@ initTcDsForSolver thing_inside Just ret -> pure ret Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } -mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv +mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> PromotionTickContext -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var +mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" -- Failing tests here are `ghci` and `T11985` if you get this wrong. @@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) + query <- liftIO $ hscUnitIndexQuery hsc_env + res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of Left recomp -> return $ NeedsRecompile recomp Right es -> do ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -358,7 +358,7 @@ loadCmdLineLibs' interp hsc_env pls = snd <$> let hsc' = hscSetActiveUnitId uid hsc_env -- Load potential dependencies first (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls) - (homeUnitDepends (hsc_units hsc')) + (Set.toList (homeUnitDepends (hsc_units hsc'))) pls'' <- loadCmdLineLibs'' interp hsc' pls' return $ (Set.insert uid done', pls'') ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -27,6 +27,7 @@ module GHC.Rename.Names ( getMinimalImports, printMinimalImports, renamePkgQual, renameRawPkgQual, + hscRenamePkgQual, hscRenameRawPkgQual, classifyGREs, ImportDeclUsage, ) where @@ -337,7 +338,8 @@ rnImportDecl this_mod hsc_env <- getTopEnv unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual -- Check for self-import, which confuses the typechecker (#9032) -- ghc --make rejects self-import cycles already, but batch-mode may not @@ -447,14 +449,14 @@ rnImportDecl this_mod -- | Rename raw package imports -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual -renameRawPkgQual unit_env mn = \case +renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env query mn = \case NoRawPkgQual -> NoPkgQual - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) + RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p)) -- | Rename raw package imports -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual -renamePkgQual unit_env mn mb_pkg = case mb_pkg of +renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual +renamePkgQual unit_env query mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs | Just uid <- homeUnitId <$> ue_homeUnit unit_env @@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names -> ThisPkg uid - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) + | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs) -> OtherPkg uid | otherwise @@ -472,13 +474,35 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of -- not really correct as pkg_fs is unlikely to be a valid unit-id but -- we will report the failure later... where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + home_names = + [ (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env))) + | uid <- S.toList hpt_deps + ] units = ue_units unit_env - hpt_deps :: [UnitId] + hpt_deps :: S.Set UnitId hpt_deps = homeUnitDepends units +hscRenameRawPkgQual :: + MonadIO m => + HscEnv -> + ModuleName -> + RawPkgQual -> + m PkgQual +hscRenameRawPkgQual hsc_env name raw = do + query <- liftIO $ hscUnitIndexQuery hsc_env + pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw) + +hscRenamePkgQual :: + MonadIO m => + HscEnv -> + ModuleName -> + Maybe FastString -> + m PkgQual +hscRenamePkgQual hsc_env name package = do + query <- liftIO $ hscUnitIndexQuery hsc_env + pure (renamePkgQual (hsc_unit_env hsc_env) query name package) -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'. ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) import GHC.Unit import GHC.Unit.Env +import GHC.Unit.State (UnitIndexQuery) import GHC.Core.FamInstEnv import GHC.Core.InstEnv @@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) ] -- | Get the NamePprCtx function based on the flags and this InteractiveContext -icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx -icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) +icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx +icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt) where ptc = initPromotionTickContext (ic_dflags ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let unit_state = ue_units unit_env let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name + query <- hscUnitIndexQuery hsc_env + found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name case found_module of Found _ mod -> do -- Find the exports of the module ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum ; when (notNull prel_imports) $ do addDiagnostic TcRnImplicitImportOfPrelude + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) = - ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) + ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl) , reLoc $ ideclName idecl) } ; raw_sig_imports <- liftIO @@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside (loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg) + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) - (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) + IIDecl i -> do + qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i) + getOrphans (unLoc (ideclName i)) qual ; let imports = emptyImportAvails { imp_orphs = orphs } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -869,7 +869,8 @@ getNamePprCtx = do { ptc <- initPromotionTickContext <$> getDynFlags ; rdr_env <- getGlobalRdrEnv ; hsc_env <- getTopEnv - ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env } + ; query <- liftIO $ hscUnitIndexQuery hsc_env + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () ===================================== compiler/GHC/Types/Name/Ppr.hs ===================================== @@ -13,6 +13,7 @@ import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env +import GHC.Unit.State (UnitIndexQuery) import GHC.Types.Name import GHC.Types.Name.Reader @@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx -mkNamePprCtx ptc unit_env env +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx +mkNamePprCtx ptc unit_env index env = QueryQualify (mkQualName env) - (mkQualModule unit_state home_unit) + (mkQualModule unit_state index home_unit) (mkQualPackage unit_state) (mkPromTick ptc env) where @@ -206,8 +207,8 @@ Side note (int-index): -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule -mkQualModule unit_state mhome_unit mod +mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule +mkQualModule unit_state index mhome_unit mod | Just home_unit <- mhome_unit , isHomeModule home_unit mod = False @@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod = False | otherwise = True - where lookup = lookupModuleInAllUnits unit_state (moduleName mod) + where lookup = lookupModuleInAllUnits unit_state index (moduleName mod) -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -100,6 +100,8 @@ data UnitEnv = UnitEnv , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + + , ue_index :: !UnitIndex } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache + ue_index <- newUnitIndex return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever + , ue_index } -- | Get home-unit @@ -138,7 +142,7 @@ ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) loop acc (uid:uids) | uid `Set.member` acc = loop acc uids | otherwise = - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) + let hue = Set.toList (homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))) in loop (Set.insert uid acc) (hue ++ uids) ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -67,8 +67,9 @@ import Control.Monad import Data.Time import qualified Data.Map as M import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery ) import GHC.Driver.Config.Finder +import GHC.Unit.Module.Graph (mgHomeModuleMap, ModuleNameHomeMap) import qualified Data.Set as Set import qualified Data.List.NonEmpty as NE @@ -162,28 +163,36 @@ findImportedModule hsc_env mod pkg_qual = dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags in do - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual + query <- hscUnitIndexQuery hsc_env + let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query home_module_map mhome_unit mod pkg_qual findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv + -> UnitIndexQuery + -> ModuleNameHomeMap -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue query home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) + | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where + (complete_units, module_name_map) = home_module_map + module_home_units = M.findWithDefault Set.empty mod_name module_name_map + current_unit_id = homeUnitId <$> mhome_unit all_opts = case mhome_unit of - Nothing -> other_fopts - Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts + Nothing -> other_fopts_list + Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts_list + other_fopts_map = M.fromList other_fopts_list home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -194,7 +203,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | mod_name `Set.member` finder_reexportedModules opts = - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue query home_module_map (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual | mod_name `Set.member` finder_hiddenModules opts = return (mkHomeHidden uid) | otherwise = @@ -203,32 +212,44 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts_list) - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg + pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg unqual_import = any_home_import `orIfNotFound` - findExposedPackageModule fc fopts units mod_name NoPkgQual + findExposedPackageModule fc fopts units query mod_name NoPkgQual units = case mhome_unit of Nothing -> ue_units ue Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue - hpt_deps :: [UnitId] + hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + dep_providers = Set.intersection module_home_units hpt_deps + known_other_uids = + let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id + in Set.toList providers + unknown_units = + let candidates = Set.difference hpt_deps complete_units + excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + in Set.toList (Set.difference candidates excluded) + other_home_uids = known_other_uids ++ unknown_units + other_fopts_list = + [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) + | uid <- other_home_uids + ] -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModule fc fopts units query (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` - findExposedPluginPackageModule fc fopts units mod_name -findPluginModule fc fopts units Nothing mod_name = - findExposedPluginPackageModule fc fopts units mod_name + findExposedPluginPackageModule fc fopts units query mod_name +findPluginModule fc fopts units query Nothing mod_name = + findExposedPluginPackageModule fc fopts units query mod_name -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out @@ -284,15 +305,15 @@ homeSearchCache fc home_unit mod_name do_this = do let mod = mkModule home_unit mod_name modLocationCache fc mod do_this -findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult -findExposedPackageModule fc fopts units mod_name mb_pkg = +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult +findExposedPackageModule fc fopts units query mod_name mb_pkg = findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + $ lookupModuleWithSuggestions units query mod_name mb_pkg -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult -findExposedPluginPackageModule fc fopts units mod_name = +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult +findExposedPluginPackageModule fc fopts units query mod_name = findLookupResult fc fopts - $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual + $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult findLookupResult fc fopts r = case r of ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -18,6 +18,8 @@ module GHC.Unit.Module.Graph , mgModSummaries , mgModSummaries' , mgLookupModule + , ModuleNameHomeMap + , mgHomeModuleMap , showModMsg , moduleGraphNodeModule , moduleGraphNodeModSum @@ -153,23 +155,31 @@ instance Outputable ModNodeKeyWithUid where -- check that the module and its hs-boot agree. -- -- The graph is not necessarily stored in topologically-sorted order. Use +type ModuleNameHomeMap = (Set UnitId, Map.Map ModuleName (Set UnitId)) + -- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. data ModuleGraph = ModuleGraph { mg_mss :: [ModuleGraphNode] , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) -- A cached transitive dependency calculation so that a lot of work is not -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances) + , mg_home_map :: ModuleNameHomeMap + -- ^ For each module name, which home-unit UnitIds define it together with the set of units for which the listing is complete. } -- | Map a function 'f' over all the 'ModSummaries'. -- To preserve invariants 'f' can't change the isBoot status. mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + { mg_mss = new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = + flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps (f ms) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -177,11 +187,27 @@ unionMG a b = in ModuleGraph { mg_mss = new_mss , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False +mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap +mkHomeModuleMap nodes = + (complete_units, provider_map) + where + provider_map = + Map.fromListWith Set.union + [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + | ModuleNode _ ms <- nodes + ] + complete_units = + Set.fromList + [ ms_unitid ms + | ModuleNode _ ms <- nodes + ] + mgModSummaries :: ModuleGraph -> [ModSummary] mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] @@ -200,8 +226,11 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap +mgHomeModuleMap = mg_home_map + emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (Set.empty, Map.empty) isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms = @@ -213,9 +242,12 @@ isTemplateHaskellOrQQNonBoot ms = -- not an element of the ModuleGraph. extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph extendMG ModuleGraph{..} deps ms = ModuleGraph - { mg_mss = ModuleNode deps ms : mg_mss - , mg_graph = mkTransDeps (ModuleNode deps ms : mg_mss) + { mg_mss = new_mss + , mg_graph = mkTransDeps new_mss + , mg_home_map = mkHomeModuleMap new_mss } + where + new_mss = ModuleNode deps ms : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1,6 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, OverloadedRecordDot, RecordWildCards #-} -- | Unit manipulation module GHC.Unit.State ( @@ -49,6 +49,15 @@ module GHC.Unit.State ( closeUnitDeps', mayThrowUnitErr, + UnitConfig (..), + UnitIndex (..), + UnitIndexQuery (..), + UnitVisibility (..), + VisibilityMap, + ModuleNameProvidersMap, + newUnitIndex, + unitIndexQuery, + -- * Module hole substitution ShHoleSubst, renameHoleUnit, @@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set import GHC.LanguageExtensions import Control.Applicative +import Control.Monad.IO.Class (MonadIO (..)) +import Data.IORef (IORef, newIORef, readIORef) -- --------------------------------------------------------------------------- -- The Unit state @@ -458,7 +469,7 @@ data UnitState = UnitState { -- -Wunused-packages warning. explicitUnits :: [(Unit, Maybe PackageArg)], - homeUnitDepends :: [UnitId], + homeUnitDepends :: Set UnitId, -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want @@ -493,7 +504,7 @@ emptyUnitState = UnitState { unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], - homeUnitDepends = [], + homeUnitDepends = Set.empty, moduleNameProvidersMap = emptyUniqMap, pluginModuleNameProvidersMap = emptyUniqMap, requirementContext = emptyUniqMap, @@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) -- | Find the UnitId which an import qualified by a package import comes from. -- Compared to 'lookupPackageName', this function correctly accounts for visibility, -- renaming and thinning. -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId -resolvePackageImport unit_st mn pn = do +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId +resolvePackageImport unit_st query mn pn = do -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc) - providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn + providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False -- 2. Get the UnitIds of the candidates let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers -- 3. Get the package names of the candidates @@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- '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 -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs home_units = do +initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags index cached_dbs home_units = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () (unit_state,dbs) <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) @@ -1021,7 +1032,7 @@ 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)) + then Left (filter (matches . fst) (nonDetEltsUniqMap unusable)) else Right (sortByPreference prec_map ps, rest) -- | Rename a 'UnitInfo' according to some module instantiation. @@ -1484,9 +1495,11 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> UnitId -> UnitConfig + -> UnitIndex -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState logger cfg = do +mkUnitState logger unit cfg index = do {- Plan. @@ -1542,15 +1555,9 @@ mkUnitState logger cfg = do -- if databases have not been provided, read the database flags raw_dbs <- case unitConfigDBCache cfg of - Nothing -> readUnitDatabases logger cfg + Nothing -> index.readDatabases logger unit cfg Just dbs -> return dbs - -- distrust all units if the flag is set - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs - | otherwise = raw_dbs - - -- This, and the other reverse's that you will see, are due to the fact that -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order -- than they are on the command line. @@ -1561,169 +1568,17 @@ mkUnitState logger cfg = do let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags - -- Merge databases together, without checking validity - (pkg_map1, prec_map) <- mergeDatabases logger dbs - - -- Now that we've merged everything together, prune out unusable - -- packages. - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 - - reportCycles logger sccs - reportUnusable logger unusable - - -- Apply trust flags (these flags apply regardless of whether - -- or not packages are visible or not) - pkgs1 <- mayThrowUnitErr - $ foldM (applyTrustFlag prec_map unusable) - (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) - let prelim_pkg_db = mkUnitInfoMap pkgs1 - - -- - -- Calculate the initial set of units from package databases, prior to any package flags. - -- - -- Conceptually, we select the latest versions of all valid (not unusable) *packages* - -- (not units). This is empty if we have -hide-all-packages. - -- - -- Then we create an initial visibility map with default visibilities for all - -- exposed, definite units which belong to the latest valid packages. - -- - let preferLater unit unit' = - case compareByPreference prec_map unit unit' of - GT -> unit - _ -> unit' - addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit - -- This is the set of maximally preferable packages. In fact, it is a set of - -- most preferable *units* keyed by package name, which act as stand-ins in - -- for "a package in a database". We use units here because we don't have - -- "a package in a database" as a type currently. - mostPreferablePackageReps = if unitConfigHideAll cfg - then emptyUDFM - else foldl' addIfMorePreferable emptyUDFM pkgs1 - -- When exposing units, we want to consider all of those in the most preferable - -- packages. We can implement that by looking for units that are equi-preferable - -- with the most preferable unit for package. Being equi-preferable means that - -- they must be in the same database, with the same version, and the same package name. - -- - -- We must take care to consider all these units and not just the most - -- preferable one, otherwise we can end up with problems like #16228. - mostPreferable u = - case lookupUDFM mostPreferablePackageReps (fsPackageName u) of - Nothing -> False - Just u' -> compareByPreference prec_map u u' == EQ - vis_map1 = foldl' (\vm p -> - -- Note: we NEVER expose indefinite packages by - -- default, because it's almost assuredly not - -- what you want (no mix-in linking has occurred). - if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p - then addToUniqMap vm (mkUnit p) - UnitVisibility { - uv_expose_all = True, - uv_renamings = [], - uv_package_name = First (Just (fsPackageName p)), - uv_requirements = emptyUniqMap, - uv_explicit = Nothing - } - else vm) - emptyUniqMap pkgs1 - - -- - -- Compute a visibility map according to the command-line flags (-package, - -- -hide-package). This needs to know about the unusable packages, since if a - -- user tries to enable an unusable package, we should let them know. - -- - vis_map2 <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable - (unitConfigHideAll cfg) pkgs1) - vis_map1 other_flags - - -- - -- Sort out which packages are wired in. This has to be done last, since - -- it modifies the unit ids of wired in packages, but when we process - -- package arguments we need to key against the old versions. - -- - (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 - let pkg_db = mkUnitInfoMap pkgs2 - - -- Update the visibility map, so we treat wired packages as visible. - let vis_map = updateVisibilityMap wired_map vis_map2 - - let hide_plugin_pkgs = unitConfigHideAllPlugins cfg - plugin_vis_map <- - case unitConfigFlagsPlugins cfg of - -- common case; try to share the old vis_map - [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return emptyUniqMap - _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = emptyUniqMap - -- Use the vis_map PRIOR to wired in, - -- because otherwise applyPackageFlag - -- won't work. - | otherwise = vis_map2 - plugin_vis_map2 - <- mayThrowUnitErr - $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable - hide_plugin_pkgs pkgs1) - plugin_vis_map1 - (reverse (unitConfigFlagsPlugins cfg)) - -- Updating based on wired in packages is mostly - -- good hygiene, because it won't matter: no wired in - -- package has a compiler plugin. - -- TODO: If a wired in package had a compiler plugin, - -- and you tried to pick different wired in packages - -- with the plugin flags and the normal flags... what - -- would happen? I don't know! But this doesn't seem - -- likely to actually happen. - return (updateVisibilityMap wired_map plugin_vis_map2) - - let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) - | p <- pkgs2 - ] - -- The explicitUnits accurately reflects the set of units we have turned - -- on; as such, it also is the only way one can come up with requirements. - -- The requirement context is directly based off of this: we simply - -- look for nested unit IDs that are directly fed holes: the requirements - -- of those units are precisely the ones we need to track - let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] - req_ctx = mapUniqMap (Set.toList) - $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) - - - -- - -- Here we build up a set of the packages mentioned in -package - -- flags on the command line; these are called the "preload" - -- packages. we link these packages in eagerly. The preload set - -- should contain at least rts & base, which is why we pretend that - -- the command line contains -package rts & -package base. - -- - -- NB: preload IS important even for type-checking, because we - -- need the correct include path to be set. - -- - let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) - - -- add default preload units if they can be found in the db - basicLinkedUnits = fmap (RealUnit . Definite) - $ filter (flip elemUniqMap pkg_db) - $ unitConfigAutoLink cfg - preload3 = ordNub $ (basicLinkedUnits ++ preload1) - - -- Close the preload packages with their dependencies - dep_preload <- mayThrowUnitErr - $ closeUnitDeps pkg_db - $ zip (map toUnitId preload3) (repeat Nothing) - - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map - mod_map2 = mkUnusableModuleNameProvidersMap unusable - mod_map = mod_map2 `plusUniqMap` mod_map1 + (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger unit cfg raw_dbs other_flags -- Force the result to avoid leaking input parameters let !state = UnitState { preloadUnits = dep_preload , explicitUnits = explicit_pkgs - , homeUnitDepends = Set.toList home_unit_deps + , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db , preloadClosure = emptyUniqSet - , moduleNameProvidersMap = mod_map - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + , moduleNameProvidersMap + , pluginModuleNameProvidersMap , packageNameMap = pkgname_map , wireMap = wired_map , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] @@ -1896,6 +1751,263 @@ addListTo = foldl' merge mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin mkModMap pkg mod = unitUniqMap (mkModule pkg mod) +-- ----------------------------------------------------------------------------- +-- Index + +data UnitIndexQuery = + UnitIndexQuery { + findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin), + index_all :: UnitState -> ModuleNameProvidersMap + } + +data UnitIndex = + UnitIndex { + query :: UnitId -> IO UnitIndexQuery, + readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId], + update :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO ( + ModuleNameProvidersMap, + ModuleNameProvidersMap, + UnitInfoMap, + [(Unit, Maybe PackageArg)], + [UnitId], + UniqMap ModuleName [InstantiatedModule], + UniqFM PackageName UnitId, + WiringMap + ) + } + +unitIndexQuery :: + MonadIO m => + UnitId -> + UnitIndex -> + m UnitIndexQuery +unitIndexQuery unit index = liftIO (index.query unit) + +data UnitIndexBackend = + UnitIndexBackend { + moduleNameProviders :: !ModuleNameProvidersMap, + pluginModuleNameProviders :: !ModuleNameProvidersMap + } + +newUnitIndexBackend :: UnitIndexBackend +newUnitIndexBackend = + UnitIndexBackend { + moduleNameProviders = mempty, + pluginModuleNameProviders = mempty + } + +queryFindOriginDefault :: + UnitIndexBackend -> + UnitState -> + ModuleName -> + Bool -> + Maybe (UniqMap Module ModuleOrigin) +queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins = + lookupUniqMap source name + where + source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap + +newUnitIndexQuery :: + MonadIO m => + IORef UnitIndexBackend -> + UnitId -> + m UnitIndexQuery +newUnitIndexQuery ref _ = do + state <- liftIO $ readIORef ref + pure UnitIndexQuery { + findOrigin = queryFindOriginDefault state, + index_all = \ s -> s.moduleNameProvidersMap + } + +updateIndexDefault :: + Logger -> + UnitId -> + UnitConfig -> + [UnitDatabase UnitId] -> + [PackageFlag] -> + IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap) +updateIndexDefault logger _ cfg raw_dbs other_flags = do + + -- distrust all units if the flag is set + let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } + dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs + | otherwise = raw_dbs + + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases logger dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1 + + reportCycles logger sccs + reportUnusable logger unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable) + (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + let prelim_pkg_db = mkUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if unitConfigHideAll cfg + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + then addToUniqMap vm (mkUnit p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = emptyUniqMap, + uv_explicit = Nothing + } + else vm) + emptyUniqMap pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + (unitConfigHideAll cfg) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 + let pkg_db = mkUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = unitConfigHideAllPlugins cfg + plugin_vis_map <- + case unitConfigFlagsPlugins cfg of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return emptyUniqMap + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = emptyUniqMap + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- mayThrowUnitErr + $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable + hide_plugin_pkgs pkgs1) + plugin_vis_map1 + (reverse (unitConfigFlagsPlugins cfg)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) + | p <- pkgs2 + ] + -- The explicitUnits accurately reflects the set of units we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] + req_ctx = mapUniqMap (Set.toList) + $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) + + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) + + -- add default preload units if they can be found in the db + basicLinkedUnits = fmap (RealUnit . Definite) + $ filter (flip elemUniqMap pkg_db) + $ unitConfigAutoLink cfg + preload3 = ordNub $ (basicLinkedUnits ++ preload1) + + -- Close the preload packages with their dependencies + dep_preload <- mayThrowUnitErr + $ closeUnitDeps pkg_db + $ zip (map toUnitId preload3) (repeat Nothing) + + let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = mod_map2 `plusUniqMap` mod_map1 + pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map + pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) + +readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId] +readDatabasesDefault logger _ cfg = + readUnitDatabases logger cfg + +newUnitIndex :: MonadIO m => m UnitIndex +newUnitIndex = do + ref <- liftIO $ newIORef newUnitIndexBackend + pure UnitIndex { + query = newUnitIndexQuery ref, + readDatabases = readDatabasesDefault, + update = updateIndexDefault + } -- ----------------------------------------------------------------------------- -- Package Utils @@ -1903,10 +2015,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod) -- | Takes a 'ModuleName', and if the module is in any package returns -- list of modules which take that name. lookupModuleInAllUnits :: UnitState + -> UnitIndexQuery -> ModuleName -> [(Module, UnitInfo)] -lookupModuleInAllUnits pkgs m - = case lookupModuleWithSuggestions pkgs m NoPkgQual of +lookupModuleInAllUnits pkgs query m + = case lookupModuleWithSuggestions pkgs query m NoPkgQual of LookupFound a b -> [(a,fst b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs @@ -1933,18 +2046,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin | SuggestHidden ModuleName Module ModuleOrigin lookupModuleWithSuggestions :: UnitState + -> UnitIndexQuery -> ModuleName -> PkgQual -> LookupResult -lookupModuleWithSuggestions pkgs - = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) +lookupModuleWithSuggestions pkgs query name + = lookupModuleWithSuggestions' pkgs query name False -- | The package which the module **appears** to come from, this could be -- the one which reexports the module from it's original package. This function -- is currently only used for -Wunused-packages -lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo] -lookupModulePackage pkgs mn mfs = - case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of +lookupModulePackage :: + UnitState -> + UnitIndexQuery -> + ModuleName -> + PkgQual -> + Maybe [UnitInfo] +lookupModulePackage pkgs query mn mfs = + case lookupModuleWithSuggestions' pkgs query mn False mfs of LookupFound _ (orig_unit, origin) -> case origin of ModOrigin {fromOrigUnit, fromExposedReexport} -> @@ -1960,19 +2079,21 @@ lookupModulePackage pkgs mn mfs = _ -> Nothing lookupPluginModuleWithSuggestions :: UnitState + -> UnitIndexQuery -> ModuleName -> PkgQual -> LookupResult -lookupPluginModuleWithSuggestions pkgs - = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs) +lookupPluginModuleWithSuggestions pkgs query name + = lookupModuleWithSuggestions' pkgs query name True lookupModuleWithSuggestions' :: UnitState - -> ModuleNameProvidersMap + -> UnitIndexQuery -> ModuleName + -> Bool -> PkgQual -> LookupResult -lookupModuleWithSuggestions' pkgs mod_map m mb_pn - = case lookupUniqMap mod_map m of +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn + = case query.findOrigin pkgs m onlyPlugins of Nothing -> LookupNotFound suggestions Just xs -> case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of @@ -2033,16 +2154,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) + | (m, e) <- nonDetUniqMapToList (query.index_all pkgs) , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) ] getSuggestion name (mod, origin) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin -listVisibleModuleNames :: UnitState -> [ModuleName] -listVisibleModuleNames state = - map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) +listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName] +listVisibleModuleNames unit_state query = + map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state))) where visible (_, ms) = anyUniqMap originVisible ms -- | Takes a list of UnitIds (and their "parent" dependency, used for error ===================================== ghc/GHCi/UI.hs ===================================== @@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession - let pkg_mods = allVisibleModules (hsc_units hsc_env) + query <- liftIO $ hscUnitIndexQuery hsc_env + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do hsc_env <- GHC.getSession + query <- liftIO $ hscUnitIndexQuery hsc_env modules <- case m of Just '-' -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allVisibleModules (hsc_units hsc_env) + let pkg_mods = allVisibleModules (hsc_units hsc_env) query loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor -- | Return a list of visible module names for autocompletion. -- (NB: exposed != visible) -allVisibleModules :: UnitState -> [ModuleName] -allVisibleModules unit_state = listVisibleModuleNames unit_state +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName] +allVisibleModules us query = listVisibleModuleNames us query completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier ===================================== ghc/GHCi/UI/Monad.hs ===================================== @@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do where mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) = - withSession $ \ hsc_env -> + withSession $ \ hsc_env -> do + query <- liftIO $ hscUnitIndexQuery hsc_env let unit_env = hsc_unit_env hsc_env ptc = initPromotionTickContext dflags - in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env + return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env printForUser :: GhcMonad m => SDoc -> m () printForUser doc = do ===================================== ghc/Main.hs ===================================== @@ -844,7 +844,8 @@ initMulti unitArgsFiles = do let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + index = hscUnitIndex hsc_env + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure $ HomeUnitEnv @@ -859,7 +860,7 @@ initMulti unitArgsFiles = do let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} } GHC.setSession final_hsc_env @@ -892,7 +893,7 @@ checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () checkUnitCycles dflags graph = processSCCs sccs where mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId - mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + mkNode (uid, hue) = DigraphNode uid uid (Set.toList (homeUnitDepends (homeUnitEnv_units hue))) nodes = map mkNode (unitEnv_elts graph) sccs = stronglyConnCompFromEdgedVerticesOrd nodes ===================================== testsuite/tests/ghc-api/downsweep/OldModLocation.hs ===================================== @@ -47,13 +47,13 @@ main = do liftIO $ do - _emss <- downsweep hsc_env [] [] False + _emss <- downsweep hsc_env [] Nothing [] False flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - (_, nodes) <- downsweep hsc_env [] [] False + (_, nodes) <- downsweep hsc_env [] Nothing [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of ===================================== testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs ===================================== @@ -168,7 +168,7 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - (_, nodes) <- liftIO $ downsweep hsc_env [] [] False + (_, nodes) <- liftIO $ downsweep hsc_env [] Nothing [] False it label $ cnd (mapMaybe moduleGraphNodeModSum nodes) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b705a78d51b8d05aa51d3b0f43921a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b705a78d51b8d05aa51d3b0f43921a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-part2] Eliminate unused variable
by Simon Peyton Jones (＠simonpj) 08 Dec '25

08 Dec '25

Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 369e35de by Simon Peyton Jones at 2025-12-08T15:06:49+00:00 Eliminate unused variable - - - - - 1 changed file: - compiler/GHC/Tc/Errors.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -2295,7 +2295,7 @@ mkQCErr ctxt items mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport -- Includes implict parameters mkDictErr ctxt orig_items@(item1 :| others) - | ClassPred cls tys <- classifyPredType (errorItemPred item1) + | ClassPred cls _ <- classifyPredType (errorItemPred item1) , isIPClass cls -- Implicit parameters; no need to look in global instance envts = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/369e35de78fcca56aa5802e74a2dc11… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/369e35de78fcca56aa5802e74a2dc11… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/int-index/imp-exp-wildcards
by Vladislav Zavialov (＠int-index) 08 Dec '25

08 Dec '25

Vladislav Zavialov pushed new branch wip/int-index/imp-exp-wildcards at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/imp-exp-wildcards You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] ignore patterns wrapped around generated src span while type checking patterns
by Apoorv Ingle (＠ani) 08 Dec '25

08 Dec '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: aba0f6e6 by Apoorv Ingle at 2025-12-07T23:32:21-06:00 ignore patterns wrapped around generated src span while type checking patterns - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Pat.hs Changes: ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -455,7 +455,7 @@ tc_lpat :: Scaled ExpSigmaTypeFRR -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside = setSrcSpanA span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat) + do { (pat', res) <- maybeWrapPatCtxt (locA span) pat (tc_pat pat_ty penv pat) thing_inside ; return (L span pat', res) } @@ -475,7 +475,7 @@ checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pa tc_forall_lpat :: TcTyVar -> Checker (LPat GhcRn) (LPat GhcTc) tc_forall_lpat tv penv (L span pat) thing_inside = setSrcSpanA span $ - do { (pat', res) <- maybeWrapPatCtxt pat (tc_forall_pat tv penv pat) + do { (pat', res) <- maybeWrapPatCtxt (locA span) pat (tc_forall_pat tv penv pat) thing_inside ; return (L span pat', res) } @@ -1921,17 +1921,19 @@ pattern (perhaps deeply) See also Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind -} -maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b +maybeWrapPatCtxt :: SrcSpan -> Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b -- Not all patterns are worth pushing a context -maybeWrapPatCtxt pat tcm thing_inside - | not (worth_wrapping pat) = tcm thing_inside +maybeWrapPatCtxt span pat tcm thing_inside + | not (worth_wrapping span pat) = tcm thing_inside | otherwise = addErrCtxt (PatCtxt pat) $ tcm $ popErrCtxt thing_inside -- Remember to pop before doing thing_inside where - worth_wrapping (VarPat {}) = False - worth_wrapping (ParPat {}) = False - worth_wrapping (AsPat {}) = False - worth_wrapping _ = True + worth_wrapping _ (VarPat {}) = False + worth_wrapping _ (ParPat {}) = False + worth_wrapping _ (AsPat {}) = False + worth_wrapping span _ + | isGeneratedSrcSpan span = False -- cf. T12957a + worth_wrapping _ _ = True ----------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aba0f6e686047457eb8d3d49298355c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/aba0f6e686047457eb8d3d49298355c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-part2] Wibbles
by Simon Peyton Jones (＠simonpj) 08 Dec '25

08 Dec '25

Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: 71a84d13 by Simon Peyton Jones at 2025-12-08T13:17:58+00:00 Wibbles - - - - - 4 changed files: - compiler/GHC/Tc/Errors.hs - testsuite/tests/typecheck/should_fail/FunDepOrigin1b.stderr - testsuite/tests/typecheck/should_fail/T19415.stderr - testsuite/tests/typecheck/should_fail/T19415b.stderr Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -652,13 +652,12 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics ] -- report2: we suppress these if there are insolubles elsewhere in the tree - report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) - , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) + report2 = [ ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] -- rigid_nom_eq, rigid_nom_tv_eq, - is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool + is_dict, is_equality, is_FRR, is_irred :: ErrorItem -> Pred -> Bool is_given_eq item pred | Given <- ei_flavour item @@ -716,9 +715,6 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics is_dict _ (ClassPred {}) = True is_dict _ _ = False - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - is_irred _ (IrredPred {}) = True is_irred _ _ = False @@ -1687,17 +1683,6 @@ givenConstraints ctxt ---------------- -mkIPErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport --- What would happen if an item is suppressed because of --- Note [Wanteds rewrite Wanteds: rewriter-sets] in GHC.Tc.Types.Constraint? --- Very unclear what's best. Let's not worry about this. -mkIPErr ctxt (item1:|others) - = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 - ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) - ; return $ add_relevant_bindings binds msg } - ----------------- - -- | Report a representation-polymorphism error to the user: -- a type is required to have a fixed runtime representation, -- but doesn't. @@ -2308,7 +2293,15 @@ mkQCErr ctxt items mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport -mkDictErr ctxt orig_items +-- Includes implict parameters +mkDictErr ctxt orig_items@(item1 :| others) + | ClassPred cls tys <- classifyPredType (errorItemPred item1) + , isIPClass cls -- Implicit parameters; no need to look in global instance envts + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) + ; return $ add_relevant_bindings binds msg } + + | otherwise = do { inst_envs <- tcGetInstEnvs ; let min_items = elim_superclasses items lookups = map (lookup_cls_inst inst_envs) min_items @@ -2362,8 +2355,8 @@ mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) { (_, rel_binds, item) <- relevantBindings True ctxt item ; candidate_insts <- get_candidate_instances ; mb_noBuiltinInst_msg <- getNoBuiltinInstMsg item - ; return $ - CannotResolveInstance item unifiers candidate_insts rel_binds mb_noBuiltinInst_msg + ; return $ CannotResolveInstance item unifiers candidate_insts rel_binds + mb_noBuiltinInst_msg } -- Some matches => overlap errors ===================================== testsuite/tests/typecheck/should_fail/FunDepOrigin1b.stderr ===================================== @@ -1,12 +1,6 @@ - FunDepOrigin1b.hs:9:10: error: [GHC-39999] - • No instance for ‘C Bool (Maybe a0)’ arising from a use of ‘op’ + • No instance for ‘C Bool (Maybe a1)’ arising from a use of ‘op’ • In the expression: op True Nothing In the expression: (op True Nothing, op False []) In an equation for ‘foo’: foo _ = (op True Nothing, op False []) -FunDepOrigin1b.hs:9:27: error: [GHC-39999] - • No instance for ‘C Bool [a1]’ arising from a use of ‘op’ - • In the expression: op False [] - In the expression: (op True Nothing, op False []) - In an equation for ‘foo’: foo _ = (op True Nothing, op False []) ===================================== testsuite/tests/typecheck/should_fail/T19415.stderr ===================================== @@ -1,5 +1,5 @@ T19415.hs:27:8: error: [GHC-39999] - • No instance for ‘SetField "name" (Pet a0) (Pet b0) Char’ + • No instance for ‘SetField "name" (Pet a0) (Pet b) Char’ arising from a use of ‘setField’ • In the expression: setField @"name" 'c' (Pet "hi") In an equation for ‘loop’: loop = setField @"name" 'c' (Pet "hi") ===================================== testsuite/tests/typecheck/should_fail/T19415b.stderr ===================================== @@ -1,5 +1,5 @@ T19415b.hs:15:8: error: [GHC-39999] - • No instance for ‘Ping (T a0) (T b0) Char’ + • No instance for ‘Ping (T a0) (T b) Char’ arising from a use of ‘foo’ • In the expression: foo 'c' MkT In an equation for ‘loop’: loop = foo 'c' MkT View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71a84d133a0f7e42fe666d318d2c667… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/71a84d133a0f7e42fe666d318d2c667… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ghc-external-custom-commands
by Matthew Pickering (＠mpickering) 08 Dec '25

08 Dec '25

Matthew Pickering pushed new branch wip/ghc-external-custom-commands at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ghc-external-custom-commands You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/unitconfig-sbs
by Cheng Shao (＠TerrorJack) 08 Dec '25

08 Dec '25

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

1 0

[Git][ghc/ghc][wip/T23162-part2] Wibble
by Simon Peyton Jones (＠simonpj) 08 Dec '25

08 Dec '25

Simon Peyton Jones pushed to branch wip/T23162-part2 at Glasgow Haskell Compiler / GHC Commits: d74825b9 by Simon Peyton Jones at 2025-12-08T10:28:57+00:00 Wibble - - - - - 2 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Types.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -648,6 +648,7 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + , ("Insoluble fundeps", is_insoluble_fundep, True, mkGroupReporter mkDictErr) ] -- report2: we suppress these if there are insolubles elsewhere in the tree @@ -665,6 +666,11 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics | otherwise = False -- I think all given residuals are equalities + -- Constraints that have insoluble functional dependencies + is_insoluble_fundep item _ = case ei_m_reason item of + Just InsolubleFunDepReason -> True + _ -> False + -- Things like (Int ~N Bool) utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 utterly_wrong _ _ = False ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -5423,7 +5423,7 @@ getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics -- that will give rise to a diagnostic. data ErrorItem -- We could perhaps use Ct here (and indeed used to do exactly that), but --- having a separate type gives to denote errors-in-formation gives us +-- having a separate type to denote error-information gives us -- a nice place to do pre-processing, such as calculating ei_suppress. -- Perhaps some day, an ErrorItem could eventually evolve to contain -- the error text (or some representation of it), so we can then have all @@ -5436,7 +5436,7 @@ data ErrorItem -- for Givens, Nothing , ei_flavour :: CtFlavour , ei_loc :: CtLoc - , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a + , ei_m_reason :: Maybe CtIrredReason -- If this ErrorItem was made from a -- CtIrred, this stores the reason , ei_suppress :: Bool -- Suppress because of -- Note [Wanteds rewrite Wanteds: rewriter-sets] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d74825b92948117f73814ea0457b999… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d74825b92948117f73814ea0457b999… You're receiving this email because of your account on gitlab.haskell.org.

1 0