[Git][ghc/ghc][wip/T26625] 25 commits: task: Substitute some datatypes for newtypes
by Teo Camarasu (＠teo) 12 Dec '25
by Teo Camarasu (＠teo) 12 Dec '25
12 Dec '25
Teo Camarasu pushed to branch wip/T26625 at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00
Fix syntax error in gadt_syntax.rst
- - - - -
91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00
ci: fix "ci.sh clean" to address frequent out of space error on windows runners
This patch fixes the `ci.sh clean` logic to address frequent out of
space error on windows runners; previously it didn't clean up the
inplace mingw blobs, which is the largest source of space leak on
windows runners. See added comment for detailed explanation.
- - - - -
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
d449a4c2 by Teo Camarasu at 2025-12-11T20:04:59+00:00
base: deprecate GHC internals in GHC.Num
Implements CLC proposal: https://github.com/haskell/core-libraries-committee/issues/360
- - - - -
142 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- compile_flags.txt
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/CmmToAsm/AArch64/RegInfo.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/RegInfo.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/Backpack.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/LlvmConfigCache.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Phases.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Type.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/ghc.cabal.in
- docs/users_guide/conf.py
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/phases.rst
- hadrian/src/Builder.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/base/src/GHC/Num.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/xhtml
- rts/linker/LoadArchive.c
- testsuite/config/ghc
- 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/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/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/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + 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
- utils/ghc-pkg/Main.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/LaTeX.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/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Utils.hs
- utils/haddock/html-test/ref/Bug1050.html
- 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/LinearTypes.html
- utils/haddock/html-test/ref/Nesting.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TitledPicture.html
- utils/haddock/html-test/ref/TypeOperators.html
- utils/haddock/html-test/ref/Unicode.html
- utils/haddock/html-test/ref/Unicode2.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9bd917d87b541147dc1eae2efc9bf4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9bd917d87b541147dc1eae2efc9bf4…
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] 2 commits: Various downsweep perf tweaks
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
12 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning-2 at Glasgow Haskell Compiler / GHC
Commits:
ad1d03ec by Matthew Pickering at 2025-12-11T19:44:01+01:00
Various downsweep perf tweaks
- - - - -
f20cef54 by Torsten Schmits at 2025-12-11T19:44:01+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
25 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
- compiler/cbits/genSym.c
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.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 (hscUnitIndex hsc_env) (hscActiveUnitId 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
@@ -2326,7 +2339,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+ let implicit_sigs = []
return $
ModSummary
@@ -2384,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
=====================================
@@ -68,11 +68,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 +206,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 +218,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
=====================================
@@ -36,6 +36,7 @@ module GHC.Unit.Finder (
lookupFileCache
) where
+import GHC.Driver.Env (hsc_mod_graph)
import GHC.Prelude
import GHC.Platform.Ways
@@ -67,8 +68,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 +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
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ query <- hscUnitIndexQuery 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 +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 =
@@ -202,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
@@ -283,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, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -458,7 +466,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 +501,7 @@ emptyUnitState = UnitState {
unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
- homeUnitDepends = [],
+ homeUnitDepends = Set.empty,
moduleNameProvidersMap = emptyUniqMap,
pluginModuleNameProvidersMap = emptyUniqMap,
requirementContext = emptyUniqMap,
@@ -577,10 +585,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 <$> findOrigin query 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 +646,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})
@@ -1484,9 +1492,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 +1552,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 -> readDatabases index 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.
@@ -1562,15 +1566,20 @@ 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
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
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
@@ -1711,19 +1721,15 @@ mkUnitState logger cfg = do
$ 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
-
-- 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 +1902,76 @@ 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),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ 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 :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1979,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 +2010,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 +2043,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 findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2118,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 (moduleProviders query 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 (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
compiler/cbits/genSym.c
=====================================
@@ -9,7 +9,19 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+// Unique64 patch was present in 9.10 and later
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)
+// Unique64 patch was backported to 9.8.4
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)
+// Unique64 patch was backported to 9.6.7
+#define HAVE_UNIQUE64 1
+#endif
+
+#if !defined(HAVE_UNIQUE64)
HsWord64 ghc_unique_counter64 = 0;
#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
=====================================
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
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> 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
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_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} }
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cd00c0c62f49b24a6cde1a3de6051…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6cd00c0c62f49b24a6cde1a3de6051…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26343] 25 commits: task: Substitute some datatypes for newtypes
by Teo Camarasu (＠teo) 12 Dec '25
by Teo Camarasu (＠teo) 12 Dec '25
12 Dec '25
Teo Camarasu pushed to branch wip/T26343 at Glasgow Haskell Compiler / GHC
Commits:
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
- - - - -
d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00
Fix syntax error in gadt_syntax.rst
- - - - -
91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00
ci: fix "ci.sh clean" to address frequent out of space error on windows runners
This patch fixes the `ci.sh clean` logic to address frequent out of
space error on windows runners; previously it didn't clean up the
inplace mingw blobs, which is the largest source of space leak on
windows runners. See added comment for detailed explanation.
- - - - -
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
d790279d by Teo Camarasu at 2025-12-11T18:41:23+00:00
base: don't expose GHC.Num.{BigNat, Integer, Natural}
We no longer expose GHC.Num.{BigNat, Integer, Natural} from base instead users should get these modules from ghc-bignum.
We make this change to insulate end users from changes to GHC's implementation of big numbers.
Implements CLC proposal 359: https://github.com/haskell/core-libraries-committee/issues/359
- - - - -
151 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- compile_flags.txt
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/CmmToAsm/AArch64/RegInfo.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/RegInfo.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/Backpack.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/LlvmConfigCache.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Phases.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Phases.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Type.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/State.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/ghc.cabal.in
- docs/users_guide/conf.py
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/phases.rst
- hadrian/src/Builder.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Default.hs
- libraries/base/base.cabal.in
- libraries/base/src/Data/Array/Byte.hs
- libraries/base/src/GHC/Num.hs
- − libraries/base/src/GHC/Num/BigNat.hs
- − libraries/base/src/GHC/Num/Integer.hs
- − libraries/base/src/GHC/Num/Natural.hs
- libraries/base/src/System/CPUTime/Utils.hs
- libraries/ghc-bignum/ghc-bignum.cabal
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-experimental/src/GHC/TypeNats/Experimental.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/os-string
- libraries/unix
- rts/linker/LoadArchive.c
- testsuite/config/ghc
- 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/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/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/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + 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
- utils/ghc-pkg/Main.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/LaTeX.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/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Utils.hs
- utils/haddock/html-test/ref/Bug1050.html
- 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/LinearTypes.html
- utils/haddock/html-test/ref/Nesting.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TitledPicture.html
- utils/haddock/html-test/ref/TypeOperators.html
- utils/haddock/html-test/ref/Unicode.html
- utils/haddock/html-test/ref/Unicode2.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d16f5641b2f059d2c9ee41a35c3723…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d16f5641b2f059d2c9ee41a35c3723…
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] 2 commits: Various downsweep perf tweaks
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
12 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning-2 at Glasgow Haskell Compiler / GHC
Commits:
e959df1c by Matthew Pickering at 2025-12-11T19:32:22+01:00
Various downsweep perf tweaks
- - - - -
6cd00c0c by Torsten Schmits at 2025-12-11T19:32:31+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
27 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
- compiler/cbits/genSym.c
- 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 (hscUnitIndex hsc_env) (hscActiveUnitId 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
@@ -2326,7 +2339,8 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+-- (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
+ let implicit_sigs = []
return $
ModSummary
@@ -2384,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
=====================================
@@ -68,11 +68,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 +206,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 +218,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
=====================================
@@ -36,6 +36,7 @@ module GHC.Unit.Finder (
lookupFileCache
) where
+import GHC.Driver.Env (hsc_mod_graph)
import GHC.Prelude
import GHC.Platform.Ways
@@ -67,8 +68,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 +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
+ let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
+ query <- hscUnitIndexQuery 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 +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 =
@@ -202,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
@@ -283,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, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -458,7 +466,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 +501,7 @@ emptyUnitState = UnitState {
unwireMap = emptyUniqMap,
preloadUnits = [],
explicitUnits = [],
- homeUnitDepends = [],
+ homeUnitDepends = Set.empty,
moduleNameProvidersMap = emptyUniqMap,
pluginModuleNameProvidersMap = emptyUniqMap,
requirementContext = emptyUniqMap,
@@ -577,10 +585,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 <$> findOrigin query 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 +646,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})
@@ -1484,9 +1492,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 +1552,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 -> readDatabases index 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.
@@ -1562,15 +1566,20 @@ 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
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
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
@@ -1711,19 +1721,15 @@ mkUnitState logger cfg = do
$ 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
-
-- 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 +1902,76 @@ 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),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ 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 :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1979,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 +2010,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 +2043,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 findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2118,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 (moduleProviders query 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 (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
compiler/cbits/genSym.c
=====================================
@@ -9,7 +9,19 @@
//
// The CPP is thus about the RTS version GHC is linked against, and not the
// version of the GHC being built.
-#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+
+#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)
+// Unique64 patch was present in 9.10 and later
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)
+// Unique64 patch was backported to 9.8.4
+#define HAVE_UNIQUE64 1
+#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)
+// Unique64 patch was backported to 9.6.7
+#define HAVE_UNIQUE64 1
+#endif
+
+#if !defined(HAVE_UNIQUE64)
HsWord64 ghc_unique_counter64 = 0;
#endif
#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)
=====================================
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
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> 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
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_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} }
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/d76b200196aae74c1a1aaca95da014…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d76b200196aae74c1a1aaca95da014…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb] 5 commits: remove redundant core bindings typecheck in initWholeCoreBindings
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
by Torsten Schmits (＠torsten.schmits) 12 Dec '25
12 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC
Commits:
91d83309 by Torsten Schmits at 2025-12-11T19:30:11+01:00
remove redundant core bindings typecheck in initWholeCoreBindings
- - - - -
757dcdf0 by Georgios Karachalias at 2025-12-11T19:30:11+01:00
Use OsPath in PkgDbRef and UnitDatabase, not FilePath
- - - - -
958351f6 by Torsten Schmits at 2025-12-11T19:30:11+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
fd6ab2f7 by Torsten Schmits at 2025-12-11T19:30:11+01:00
Abstract out module provider queries into a handler type
- - - - -
2fcf61c0 by Torsten Schmits at 2025-12-11T19:30:11+01:00
Use unit index for name printing
- - - - -
27 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- + compiler/GHC/Data/OsPath.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Deps.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/State.hs
- compiler/ghc.cabal.in
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.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/Data/OsPath.hs
=====================================
@@ -0,0 +1,45 @@
+module GHC.Data.OsPath
+ (
+ -- * OsPath initialisation and transformation
+ OsPath
+ , OsString
+ , encodeUtf
+ , decodeUtf
+ , unsafeDecodeUtf
+ , unsafeEncodeUtf
+ , os
+ -- * Common utility functions
+ , (</>)
+ , (<.>)
+ , splitSearchPath
+ , isRelative
+ , dropTrailingPathSeparator
+ , takeDirectory
+ , isSuffixOf
+ , doesDirectoryExist
+ , doesFileExist
+ , getDirectoryContents
+ , createDirectoryIfMissing
+ , pprOsPath
+ )
+ where
+
+import GHC.Prelude
+
+import GHC.Utils.Misc (HasCallStack)
+import GHC.Utils.Outputable qualified as Outputable
+import GHC.Utils.Panic (panic)
+
+import System.OsPath
+import System.OsString (isSuffixOf)
+import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
+import System.Directory.Internal (os)
+
+-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
+-- Prefer 'decodeUtf' and gracious error handling.
+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
+unsafeDecodeUtf p =
+ either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
+
+pprOsPath :: HasCallStack => OsPath -> Outputable.SDoc
+pprOsPath = Outputable.text . unsafeDecodeUtf
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -76,6 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import GHC.Data.StringBuffer
import GHC.Data.FastString
+import qualified GHC.Data.OsPath as OsPath
import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.Data.ShortText as ST
@@ -429,15 +430,16 @@ 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 ->
let newdb = UnitDatabase
- { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
+ { unitDatabasePath = OsPath.unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
, 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 +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 }
@@ -870,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
@@ -882,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/DynFlags.hs
=====================================
@@ -96,6 +96,7 @@ import GHC.Core.Unfold
import GHC.Data.Bool
import GHC.Data.EnumSet (EnumSet)
import GHC.Data.Maybe
+import GHC.Data.OsPath (OsPath)
import GHC.Builtin.Names ( mAIN_NAME )
import GHC.Driver.Backend
import GHC.Driver.Flags
@@ -948,7 +949,7 @@ setDynamicNow dflags0 =
data PkgDbRef
= GlobalPkgDb
| UserPkgDb
- | PkgDbPath FilePath
+ | PkgDbPath OsPath
deriving Eq
-- | Used to differentiate the scope an include needs to apply to.
=====================================
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 (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
types_var <- newIORef (md_types details)
let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
- core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
- -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
- -- reports a bug.
- let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
-- The bytecode generation itself is lazy because otherwise even when doing
-- recompilation checking the bytecode will be generated (which slows things down a lot)
-- the laziness is OK because generateByteCode just depends on things already loaded
@@ -2578,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
=====================================
@@ -187,12 +187,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
@@ -510,15 +511,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
@@ -2384,7 +2385,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/Driver/Session.hs
=====================================
@@ -255,6 +255,7 @@ import GHC.Types.SrcLoc
import GHC.Types.SafeHaskell
import GHC.Types.Basic ( treatZeroAsInf )
import GHC.Data.FastString
+import qualified GHC.Data.OsPath as OsPath
import GHC.Utils.TmpFs
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
@@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]
package_flags_deps = [
------- Packages ----------------------------------------------------
make_ord_flag defFlag "package-db"
- (HasArg (addPkgDbRef . PkgDbPath))
+ (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf))
, make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb)
, make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb)
, make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb)
@@ -1972,7 +1973,7 @@ package_flags_deps = [
(NoArg (addPkgDbRef UserPkgDb))
-- backwards compat with GHC<=7.4 :
, make_dep_flag defFlag "package-conf"
- (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"
+ (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead"
, make_dep_flag defFlag "no-user-package-conf"
(NoArg removeUserPkgDb) "Use -no-user-package-db instead"
, make_ord_flag defGhcFlag "package-name" (HasArg $ \name ->
@@ -3377,7 +3378,7 @@ parseEnvFile :: FilePath -> String -> DynP ()
parseEnvFile envfile = mapM_ parseEntry . lines
where
parseEntry str = case words str of
- ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db))
+ ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir </> db)))
-- relative package dbs are interpreted relative to the env file
where envdir = takeDirectory envfile
db = drop 11 str
=====================================
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/Deps.hs
=====================================
@@ -53,8 +53,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import qualified Data.Set as Set
-import qualified Data.Map as M
-import Data.List (isSuffixOf)
import System.FilePath
import System.Directory
=====================================
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
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [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
=====================================
@@ -68,11 +68,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 +206,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 +218,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
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ 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 qualified Data.Set as Set
@@ -161,17 +161,19 @@ 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
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -193,7 +195,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 (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ 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
@@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- 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 +285,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/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -103,6 +111,8 @@ import GHC.Data.Maybe
import System.Environment ( getEnv )
import GHC.Data.FastString
import qualified GHC.Data.ShortText as ST
+import GHC.Data.OsPath (OsPath)
+import qualified GHC.Data.OsPath as OsPath
import GHC.Utils.Logger
import GHC.Utils.Error
import GHC.Utils.Exception
@@ -112,7 +122,7 @@ import System.FilePath as FilePath
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
-import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
+import Data.List ( intersperse, partition, sortBy, sortOn )
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
@@ -216,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -405,7 +415,7 @@ initUnitConfig dflags cached_dbs home_units =
where
offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
- offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p))
+ offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p))
offsetPackageDb _ p = p
@@ -500,12 +510,12 @@ emptyUnitState = UnitState {
-- | Unit database
data UnitDatabase unit = UnitDatabase
- { unitDatabasePath :: FilePath
+ { unitDatabasePath :: OsPath
, unitDatabaseUnits :: [GenUnitInfo unit]
}
instance Outputable u => Outputable (UnitDatabase u) where
- ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
+ ppr (UnitDatabase fp _u) = text "DB:" <+> OsPath.pprOsPath fp
type UnitInfoMap = UniqMap UnitId UnitInfo
@@ -575,10 +585,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 <$> findOrigin query 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
@@ -636,14 +646,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})
@@ -720,9 +730,9 @@ getUnitDbRefs cfg = do
Left _ -> system_conf_refs
Right path
| Just (xs, x) <- snocView path, isSearchPathSeparator x
- -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
+ -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
| otherwise
- -> map PkgDbPath (splitSearchPath path)
+ -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
-- Apply the package DB-related flags from the command line to get the
-- final list of package DBs.
@@ -751,24 +761,24 @@ getUnitDbRefs cfg = do
-- NB: This logic is reimplemented in Cabal, so if you change it,
-- make sure you update Cabal. (Or, better yet, dump it in the
-- compiler info so Cabal can use the info.)
-resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
-resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
+resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath)
+resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg
resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
let pkgconf = dir </> unitConfigDBName cfg
exist <- tryMaybeT $ doesDirectoryExist pkgconf
- if exist then return pkgconf else mzero
+ if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
-readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
+readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
readUnitDatabase logger cfg conf_file = do
- isdir <- doesDirectoryExist conf_file
+ isdir <- OsPath.doesDirectoryExist conf_file
proto_pkg_configs <-
if isdir
then readDirStyleUnitInfo conf_file
else do
- isfile <- doesFileExist conf_file
+ isfile <- OsPath.doesFileExist conf_file
if isfile
then do
mpkgs <- tryReadOldFileStyleUnitInfo
@@ -776,48 +786,49 @@ readUnitDatabase logger cfg conf_file = do
Just pkgs -> return pkgs
Nothing -> throwGhcExceptionIO $ InstallationError $
"ghc no longer supports single-file style package " ++
- "databases (" ++ conf_file ++
+ "databases (" ++ show conf_file ++
") use 'ghc-pkg init' to create the database with " ++
"the correct format."
else throwGhcExceptionIO $ InstallationError $
- "can't find a package database at " ++ conf_file
+ "can't find a package database at " ++ show conf_file
let
-- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
- conf_file' = dropTrailingPathSeparator conf_file
- top_dir = unitConfigGHCDir cfg
- pkgroot = takeDirectory conf_file'
+ conf_file' = OsPath.dropTrailingPathSeparator conf_file
+ top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) -- TODO: hm.
+ pkgroot = OsPath.takeDirectory conf_file'
pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
proto_pkg_configs
--
return $ UnitDatabase conf_file' pkg_configs1
where
+ readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
readDirStyleUnitInfo conf_dir = do
- let filename = conf_dir </> "package.cache"
- cache_exists <- doesFileExist filename
+ let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")
+ cache_exists <- OsPath.doesFileExist filename
if cache_exists
then do
- debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
- readPackageDbForGhc filename
+ debugTraceMsg logger 2 $ text "Using binary package database:" <+> OsPath.pprOsPath filename
+ readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) -- TODO: Can we help it with this one? it comes from the ghc-boot package
else do
-- If there is no package.cache file, we check if the database is not
-- empty by inspecting if the directory contains any .conf file. If it
-- does, something is wrong and we fail. Otherwise we assume that the
-- database is empty.
debugTraceMsg logger 2 $ text "There is no package.cache in"
- <+> text conf_dir
+ <+> OsPath.pprOsPath conf_dir
<> text ", checking if the database is empty"
- db_empty <- all (not . isSuffixOf ".conf")
- <$> getDirectoryContents conf_dir
+ db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
+ <$> OsPath.getDirectoryContents conf_dir
if db_empty
then do
debugTraceMsg logger 3 $ text "There are no .conf files in"
- <+> text conf_dir <> text ", treating"
+ <+> OsPath.pprOsPath conf_dir <> text ", treating"
<+> text "package database as empty"
return []
else
throwGhcExceptionIO $ InstallationError $
- "there is no package.cache in " ++ conf_dir ++
+ "there is no package.cache in " ++ show conf_dir ++
" even though package database is not empty"
@@ -830,13 +841,13 @@ readUnitDatabase logger cfg conf_file = do
-- assumes it's a file and tries to overwrite with 'writeFile'.
-- ghc-pkg also cooperates with this workaround.
tryReadOldFileStyleUnitInfo = do
- content <- readFile conf_file `catchIO` \_ -> return ""
+ content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
if take 2 content == "[]"
then do
- let conf_dir = conf_file <.> "d"
- direxists <- doesDirectoryExist conf_dir
+ let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
+ direxists <- OsPath.doesDirectoryExist conf_dir
if direxists
- then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
+ then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> OsPath.pprOsPath conf_dir)
liftM Just (readDirStyleUnitInfo conf_dir)
else return (Just []) -- ghc-pkg will create it when it's updated
else return Nothing
@@ -846,11 +857,12 @@ distrustAllUnits pkgs = map distrust pkgs
where
distrust pkg = pkg{ unitIsTrusted = False }
-mungeUnitInfo :: FilePath -> FilePath
+-- TODO: Can we help it with this one? it comes from the ghc-boot package
+mungeUnitInfo :: OsPath -> OsPath
-> UnitInfo -> UnitInfo
mungeUnitInfo top_dir pkgroot =
mungeDynLibFields
- . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
+ . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields pkg =
@@ -1388,7 +1400,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..]
where
merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
debugTraceMsg logger 2 $
- text "loading package database" <+> text db_path
+ text "loading package database" <+> OsPath.pprOsPath db_path
forM_ (Set.toList override_set) $ \pkg ->
debugTraceMsg logger 2 $
text "package" <+> ppr pkg <+>
@@ -1480,9 +1492,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.
@@ -1538,15 +1552,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 -> readDatabases index 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.
@@ -1558,15 +1566,20 @@ 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
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1671,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1683,8 +1699,6 @@ mkUnitState logger cfg = do
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
@@ -1707,10 +1721,6 @@ mkUnitState logger cfg = do
$ 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
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1718,8 +1728,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList 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 ]
@@ -1892,6 +1902,76 @@ 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),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ 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 :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1899,10 +1979,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
@@ -1929,18 +2010,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} ->
@@ -1956,19 +2043,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 findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2029,16 +2118,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 (moduleProviders query 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 (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
compiler/ghc.cabal.in
=====================================
@@ -115,6 +115,7 @@ Library
containers >= 0.6.2.1 && < 0.8,
array >= 0.1 && < 0.6,
filepath >= 1 && < 1.6,
+ os-string >= 2.0.1 && < 2.1,
template-haskell == 2.22.*,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
@@ -430,6 +431,7 @@ Library
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+ GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Stream
=====================================
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
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> 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
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_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} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a9ec6e888f194d79615f790b7228a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a9ec6e888f194d79615f790b7228a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/obtaining-os-handles] 197 commits: rts: Refactor parsing of -h flags
by Wolfgang Jeltsch (＠jeltsch) 11 Dec '25
by Wolfgang Jeltsch (＠jeltsch) 11 Dec '25
11 Dec '25
Wolfgang Jeltsch pushed to branch wip/jeltsch/obtaining-os-handles at Glasgow Haskell Compiler / GHC
Commits:
d9e2a9a7 by mniip at 2025-09-26T16:00:50-04:00
rts: Refactor parsing of -h flags
We have a nontrivial amount of heap profiling flags available in the
non-profiled runtime, so it makes sense to reuse the parsing code
between the profiled and the non-profiled runtime, only restricting
which flags are allowed.
- - - - -
089e45aa by mniip at 2025-09-26T16:00:50-04:00
rts: Fix parsing of -h options with braces
When the "filter by" -h options were introduced in
bc210f7d267e8351ccb66972f4b3a650eb9338bb, the braces were mandatory.
Then in 3c22fb21fb18e27ce8d941069a6915fce584a526, the braces were made
optional. Then in d1ce35d2271ac8b79cb5e37677b1a989749e611c the brace
syntax stopped working, and no one seems to have noticed.
- - - - -
423f1472 by mniip at 2025-09-26T16:00:50-04:00
rts: add -hT<type> and -hi<table id> heap filtering options (#26361)
They are available in non-profiled builds.
Along the way fixed a bug where combining -he<era> and -hr<retainer>
would ignore whether the retainer matches or not.
- - - - -
4cda4785 by mniip at 2025-09-26T16:00:50-04:00
docs: Document -hT<type> and -hi<addr>
- - - - -
982ad30f by mniip at 2025-09-26T16:00:50-04:00
rts: Refactor dumping the heap census
Always do the printing of the total size right next to where the bucket
label is printed. This prevents accidentally printing a label without
the corresponding amount.
Fixed a bug where exactly this happened for -hi profile and the 0x0
(uncategorized) info table.
There is now also much more symmetry between fprintf(hp_file,...) and
the corresponding traceHeapProfSampleString.
- - - - -
8cbe006a by Cheng Shao at 2025-09-26T16:01:34-04:00
hadrian: fix GHC.Platform.Host generation for cross stage1
This patch fixes incorrectly GHC.Platform.Host generation logic for
cross stage1 in hadrian (#26449). Also adds T26449 test case to
witness the fix.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
0ddd0fdc by soulomoon at 2025-09-28T19:24:10-04:00
Remove hptAllInstances usage during upsweep
Previously, during the upsweep phase when
checking safe imports, we were loading the module
interface with runTcInteractive, which in turn calls
hptAllInstances. This accesses non-below modules
from the home package table.
Change the implementation of checkSafeImports
to use initTcWithGbl and loadSysInterface to load the
module interface, since we already have TcGblEnv at hand.
This eliminates the unnecessary use of runTcInteractive
and hptAllInstances during the upsweep phase.
- - - - -
e05c496c by Ben Gamari at 2025-09-28T19:24:59-04:00
base: Update changelog to reflect timing of IOPort# removal
This change will make 9.14 afterall.
- - - - -
bdc9d130 by Cheng Shao at 2025-09-28T19:25:45-04:00
rts: fix wasm JSFFI initialization constructor code
This commit fixes wasm JSFFI initialization constructor code so that
the constructor is self-contained and avoids invoking a fake
__main_argc_argv function. The previous approach of reusing
__main_void logic in wasi-libc saves a tiny bit of code, at the
expense of link-time trouble whenever GHC links a wasm module without
-no-hs-main, in which case the driver-generated main function would
clash with the definition here, resulting in a linker error. It's
simply better to avoid messing with the main function, and it would
additionally allow linking wasm32-wasi command modules that does make
use of synchronous JSFFI.
- - - - -
5d59fc8f by Cheng Shao at 2025-09-28T19:26:27-04:00
rts: provide stub implementations of ExecPage functions for wasm
This patch provides stub implementations of ExecPage functions for
wasm. They are never actually invoked at runtime for any non-TNTC
platform, yet they can cause link-time errors of missing symbols when
the GHCi.InfoTable module gets linked into the final wasm module (e.g.
a GHC API program).
- - - - -
a4d664c7 by Cheng Shao at 2025-09-29T17:29:22+02:00
compiler/ghci: replace the LoadDLL message with LoadDLLs
As a part of #25407, this commit changes the LoadDLL message to
LoadDLLs, which takes a list of DLL paths to load and returns the list
of remote pointer handles. The wasm dyld is refactored to take
advantage of LoadDLLs and harvest background parallelism. On other
platforms, LoadDLLs is based on a fallback codepath that does
sequential loading.
The driver is not actually emitting singular LoadDLLs message with
multiple DLLs yet, this is left in subsequent commits.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
c7fc4bae by Cheng Shao at 2025-09-29T17:29:22+02:00
driver: separate downsweep/upsweep phase in loadPackages'
This commit refactors GHC.Linker.Loader.loadPackages' to be separated
into downsweep/upsweep phases:
- The downsweep phase performs dependency analysis and generates a
list of topologically sorted packages to load
- The upsweep phase sequentially loads these packages by calling
loadPackage
This is a necessary refactoring to make it possible to make loading of
DLLs concurrent.
- - - - -
ab180104 by Cheng Shao at 2025-09-29T17:57:19+02:00
driver: emit single LoadDLLs message to load multiple DLLs
This commit refactors the driver so that it emits a single LoadDLLs
message to load multiple DLLs in GHC.Linker.Loader.loadPackages'.
Closes #25407.
-------------------------
Metric Increase:
MultiLayerModulesTH_OneShot
TcPlugin_RewritePerf
-------------------------
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
9c304ec0 by Sean D. Gillespie at 2025-09-29T19:57:07-04:00
Fix SIZED_BIN_OP_TY_INT casts in RTS interpreter
Correct `SIZED_BIN_OP_TY_INT` cast to integer. Previously, it cast
its second operand as its parameter `ty`. This does not currently
cause any issues, since we are only using it for bit shifts.
Fixes #26287
- - - - -
a1de535f by Luite Stegeman at 2025-09-30T18:40:28-04:00
rts: Fix lost wakeups in threadPaused for threads blocked on black holes
The lazy blackholing code in threadPaused could overwrite closures
that were already eagerly blackholed, and as such wouldn't have a
marked update frame. If the black hole was overwritten by its
original owner, this would lead to an undetected collision, and
the contents of any existing blocking queue being lost.
This adds a check for eagerly blackholed closures and avoids
overwriting their contents.
Fixes #26324
- - - - -
b7e21e49 by Luite Stegeman at 2025-09-30T18:40:28-04:00
rts: push the correct update frame in stg_AP_STACK
The frame contains an eager black hole (__stg_EAGER_BLACKHOLE_info) so
we should push an stg_bh_upd_frame_info instead of an stg_upd_frame_info.
- - - - -
02a7c18a by Cheng Shao at 2025-09-30T18:41:27-04:00
ghci: fix lookupSymbolInDLL behavior on wasm
This patch fixes lookupSymbolInDLL behavior on wasm to return Nothing
instead of throwing. On wasm, we only have lookupSymbol, and the
driver would attempt to call lookupSymbolInDLL first before falling
back to lookupSymbol, so lookupSymbolInDLL needs to return Nothing
gracefully for the fallback behavior to work.
- - - - -
aa0ca5e3 by Cheng Shao at 2025-09-30T18:41:27-04:00
hadrian/compiler: enable internal-interpreter for ghc library in wasm stage1
This commit enables the internal-interpreter flag for ghc library in
wasm stage1, as well as other minor adjustments to make it actually
possible to launch a ghc api session that makes use of the internal
interpreter. Closes #26431 #25400.
- - - - -
69503668 by Cheng Shao at 2025-09-30T18:41:27-04:00
testsuite: add T26431 test case
This commit adds T26431 to testsuite/tests/ghci-wasm which goes
through the complete bytecode compilation/linking/running pipeline in
wasm, so to witness that the ghc shared library in wasm have full
support for internal-interpreter.
- - - - -
e9445c01 by Matthew Pickering at 2025-09-30T18:42:23-04:00
driver: Load bytecode static pointer entries during linking
Previously the entries were loaded too eagerly, during upsweep, but we
should delay loading them until we know that the relevant bytecode
object is demanded.
Towards #25230
- - - - -
b8307eab by Cheng Shao at 2025-09-30T18:43:14-04:00
autoconf/ghc-toolchain: remove obsolete C99 check
This patch removes obsolete c99 check from autoconf/ghc-toolchain. For
all toolchain & platform combination we support, gnu11 or above is
already supported without any -std flag required, and our RTS already
required C11 quite a few years ago, so the C99 check is completely
pointless.
- - - - -
9c293544 by Simon Peyton Jones at 2025-10-01T09:36:10+01:00
Fix buglet in GHC.Core.Unify.uVarOrFam
We were failing to match two totally-equal types!
This led to #26457.
- - - - -
554487a7 by Rodrigo Mesquita at 2025-10-01T23:04:43-04:00
cleanup: Drop obsolete comment about HsConDetails
HsConDetails used to have an argument representing the type of the
tyargs in a list:
data HsConDetails tyarg arg rec
= PrefixCon [tyarg] [arg]
This datatype was shared across 3 synonyms: HsConPatDetails,
HsConDeclH98Details, HsPatSynDetails. In the latter two cases, `tyarg`
was instanced to `Void` meaning the list was always empty for these
cases.
In 7b84c58867edca57a45945a20a9391724db6d9e4, this was refactored such
that HsConDetails no longer needs a type of tyargs by construction. The
first case now represents the type arguments in the args type itself,
with something like:
ConPat "MkE" [InvisP tp1, InvisP tp2, p1, p2]
So the deleted comment really is just obsolete.
Fixes #26461
- - - - -
6992ac09 by Cheng Shao at 2025-10-02T07:27:55-04:00
testsuite: remove unused expected output files
This patch removes unused expected output files in the testsuites on
platforms that we no longer support.
- - - - -
39eaaaba by Ben Gamari at 2025-10-02T07:28:45-04:00
rts: Dynamically initialize built-in closures
To resolve #26166 we need to eliminate references to undefined symbols
in the runtime system. One such source of these is the runtime's
static references to `I#` and `C#` due the `stg_INTLIKE` and
`stg_CHARLIKE` arrays.
To avoid this we make these dynamic, initializing them during RTS
start-up.
- - - - -
c254c54b by Cheng Shao at 2025-10-02T07:29:33-04:00
compiler: only invoke keepCAFsForGHCi if internal-interpreter is enabled
This patch makes the ghc library only invoke keepCAFsForGHCi if
internal-interpreter is enabled. For cases when it's not (e.g. the
host build of a cross ghc), this avoids unnecessarily retaining all
CAFs in the heap. Also fixes the type signature of c_keepCAFsForGHCi
to match the C ABI.
- - - - -
c9ec4d43 by Simon Hengel at 2025-10-02T18:42:20-04:00
Update copyright in documentation
- - - - -
da9633a9 by Matthew Pickering at 2025-10-02T18:43:04-04:00
loader: Unify loadDecls and loadModuleLinkables functions
These two functions nearly did the same thing. I have refactored them so
that `loadDecls` now calls `loadModuleLinkables`.
Fixes #26459
- - - - -
5db98d80 by Simon Hengel at 2025-10-02T18:43:53-04:00
Fix typo
- - - - -
1275d360 by Matthew Pickering at 2025-10-03T06:05:56-04:00
testsuite: Use ghci_ways to set ways in PackedDataCon/UnboxedTuples/UnliftedDataTypeInterp tests
These tests reimplemented the logic from `valid_way` in order to
determine what ways to run. It's easier to use this combination of
`only_ways` and `extra_ways` to only run in GHCi ways and always run in
GHCi ways.
- - - - -
c06b534b by Matthew Pickering at 2025-10-03T06:06:40-04:00
Rename interpreterBackend to bytecodeBackend
This is preparation for creating bytecode files.
The "interpreter" is one way in which we can run bytecode objects. It is
more accurate to describe that the backend produces bytecode, rather
than the means by which the code will eventually run.
The "interpreterBackend" binding is left as a deprecated alias.
- - - - -
41bdb16f by Andreas Klebinger at 2025-10-06T18:04:34-04:00
Add a perf test for #26425
- - - - -
1da0c700 by Andreas Klebinger at 2025-10-06T18:05:14-04:00
Testsuite: Silence warnings about Wx-partial in concprog001
- - - - -
7471eb6a by sheaf at 2025-10-07T21:39:43-04:00
Improve how we detect user type errors in types
This commit cleans up all the code responsible for detecting whether a
type contains "TypeError msg" applications nested inside it. All the
logic is now in 'userTypeError_maybe', which is always deep. Whether
it looks inside type family applications is determined by the passed-in
boolean flag:
- When deciding whether a constraint is definitely insoluble, don't
look inside type family applications, as they may still reduce -- in
which case the TypeError could disappear.
- When reporting unsolved constraints, look inside type family
applications: they had the chance to reduce but didn't, and the
custom type error might contain valuable information.
All the details are explained in Note [Custom type errors in constraints]
in GHC.Tc.Types.Constraint.
Another benefit of this change is that it allows us to get rid of the
deeply dodgy 'getUserTypeErrorMsg' function.
This commit also improves the detection of custom type errors, for
example in equality constraints:
TypeError blah ~# rhs
It used to be the case that we didn't detect the TypeError on the LHS,
because we never considered that equality constraints could be insoluble
due to the presence of custom type errors. Addressing this oversight
improves detection of redundant pattern match warnings, fixing #26400.
- - - - -
29955267 by Rodrigo Mesquita at 2025-10-07T21:40:25-04:00
cleanup: Drop obsolete settings from config.mk.in
These values used to be spliced into the bindist's `config.mk` s.t. when
`make` was run, the values were read and written into the bindist installation `settings` file.
However, we now carry these values to the bindist directly in the
default.target toolchain file, and `make` writes almost nothing to
`settings` now (see #26227)
The entries deleted in this MR were already unused.
Fixes #26478
- - - - -
f7adfed2 by ARATA Mizuki at 2025-10-08T08:37:24-04:00
T22033 is only relevant if the word size is 64-bit
Fixes #25497
- - - - -
ff1650c9 by Ben Gamari at 2025-10-08T08:38:07-04:00
rts/posix: Enforce iteration limit on heap reservation logic
Previously we could loop indefinitely when attempting to get an address
space reservation for our heap. Limit the logic to 8 iterations to
ensure we instead issue a reasonable error message.
Addresses #26151.
- - - - -
01844557 by Ben Gamari at 2025-10-08T08:38:07-04:00
rts/posix: Hold on to low reservations when reserving heap
Previously when the OS gave us an address space reservation in low
memory we would immediately release it and try again. However, on some
platforms this meant that we would get the same allocation again in the
next iteration (since mmap's `hint` argument is just that, a hint).
Instead we now hold on to low reservations until we have found a
suitable heap reservation.
Fixes #26151.
- - - - -
b2c8d052 by Sven Tennie at 2025-10-08T08:38:47-04:00
Build terminfo only in upper stages in cross-builds (#26288)
Currently, there's no way to provide library paths for [n]curses for
both - build and target - in cross-builds. As stage0 is only used to
build upper stages, it should be fine to build terminfo only for them.
This re-enables building cross-compilers with terminfo.
- - - - -
c58f9a61 by Julian Ospald at 2025-10-08T08:39:36-04:00
ghc-toolchain: Drop `ld.gold` from merge object command
It's deprecated.
Also see #25716
- - - - -
2b8baada by sheaf at 2025-10-08T18:23:37-04:00
Improvements to 'mayLookIdentical'
This commit makes significant improvements to the machinery that decides
when we should pretty-print the "invisible bits" of a type, such as:
- kind applications, e.g. '@k' in 'Proxy @k ty'
- RuntimeReps, e.g. 'TYPE r'
- multiplicities and linear arrows 'a %1 -> b'
To do this, this commit refactors 'mayLookIdentical' to return **which**
of the invisible bits don't match up, e.g. in
(a %1 -> b) ~ (a %Many -> b)
we find that the invisible bit that doesn't match up is a multiplicity,
so we should set 'sdocLinearTypes = True' when pretty-printing, and with
e.g.
Proxy @k1 ~ Proxy @k2
we find that the invisible bit that doesn't match up is an invisible
TyCon argument, so we set 'sdocPrintExplicitKinds = True'.
We leverage these changes to remove the ad-hoc treatment of linearity
of data constructors with 'dataConDisplayType' and 'dataConNonLinearType'.
This is now handled by the machinery of 'pprWithInvisibleBits'.
Fixes #26335 #26340
- - - - -
129ce32d by sheaf at 2025-10-08T18:23:37-04:00
Store SDoc context in SourceError
This commits modifies the SourceError datatype which is used for
throwing and then reporting exceptions by storing all the info we need
to be able to print the SDoc, including whether we should print with
explicit kinds, explicit runtime-reps, etc.
This is done using the new datatype:
data SourceErrorContext
= SEC
!DiagOpts
!(DiagnosticOpts GhcMessage)
Now, when we come to report an error (by handling the exception), we
have access to the full context we need.
Fixes #26387
- - - - -
f9790ca8 by Ben Gamari at 2025-10-08T18:24:19-04:00
gitlab-ci: Make RELEASE_JOB an input
Rather than an undocumented variable.
- - - - -
14281a22 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Fix comment spelling
- - - - -
bedd38b0 by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/nonmoving: Use atomic operations to update bd->flags
- - - - -
215d6841 by Ben Gamari at 2025-10-11T14:06:47-04:00
nonmoving: Use get_itbl instead of explicit loads
This is cleaner and also fixes unnecessary (and unsound) use of
`volatile`.
- - - - -
2c94aa3a by Ben Gamari at 2025-10-11T14:06:47-04:00
rts/Scav: Handle WHITEHOLEs in scavenge_one
`scavenge_one`, used to scavenge mutable list entries, may encounter
`WHITEHOLE`s when the non-moving GC is in use via two paths:
1. when an MVAR is being marked concurrently
2. when the object belongs to a chain of selectors being short-cutted.
Fixes #26204.
- - - - -
6bd8155c by Matthew Pickering at 2025-10-11T14:07:29-04:00
Add support for generating bytecode objects
This commit adds the `-fwrite-byte-code` option which makes GHC emit a
`.gbc` file which contains a serialised representation of bytecode.
The bytecode can be loaded by the compiler to avoid having to
reinterpret a module when using the bytecode interpreter (for example,
in GHCi).
There are also the new options:
* -gbcdir=<DIR>: Specify the directory to place the gbc files
* -gbcsuf=<suffix>: Specify the suffix for gbc files
The option `-fbyte-code-and-object-code` now implies
`-fwrite-byte-code`.
These performance tests fail due to https://github.com/haskell/directory/issues/204
-------------------------
Metric Increase:
MultiComponentModules
MultiLayerModules
MultiComponentModulesRecomp
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
MultiLayerModulesTH_OneShot
T13701
-------------------------
The bytecode serialisation part was implemented by Cheng Shao
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
- - - - -
dc8f9599 by Matthew Pickering at 2025-10-11T14:07:30-04:00
Revert "Add a perf test for #26425"
This test has a large memory spike currently, which makes the test
sensitive, since if you allocate a little more or less, the precise
location where GC happens shifts and you observe a different part of the
spike.
Andreas told me to revert the patch for now, and he will add it back
when he fixes the memory spike.
This reverts commit 41bdb16fd083110a06507248f648c507a2feb4af.
- - - - -
e10dcd65 by Sven Tennie at 2025-10-12T10:24:56+00:00
T22859: Increase threadDelay for small machines
The previously used thread delay led to failures on my RISC-V test
setups.
- - - - -
d59ef6b6 by Hai / @BestYeen at 2025-10-14T21:51:14-04:00
Change Alex and Happy m4 scripts to display which version was found in the system, adapt small formatting details in Happy script to be more like the Alex script again.
- - - - -
c98abb6a by Hai / @BestYeen at 2025-10-14T21:52:08-04:00
Update occurrences of return to pure and add a sample for redefining :m to mean :main
- - - - -
70ee825a by Cheng Shao at 2025-10-14T21:52:50-04:00
testsuite: fix T3586 for non-SSE3 platforms
`T3586.hs` contains `-fvia-C -optc-msse3` which I think is a
best-effort basis to harvest the C compiler's auto vectorization
optimizations via the C backend back when the test was added. The
`-fvia-C` part is now a deprecated no-op because GHC can't fall back
to the C backend on a non-unregisterised build, and `-optc-msse3`
might actually cause the test to fail on non x86/x64 platforms, e.g.
recent builds of wasi-sdk would report `wasm32-wasi-clang: error:
unsupported option '-msse3' for target 'wasm32-unknown-wasi'`.
So this patch cleans up this historical cruft. `-fvia-C` is removed,
and `-optc-msse3` is only passed when cpuid contains `pni` (which
indicates support of SSE3).
- - - - -
4be32153 by Teo Camarasu at 2025-10-15T08:06:09-04:00
Add submodules for template-haskell-lift and template-haskell-quasiquoter
These two new boot libraries expose stable subsets of the
template-haskell interface.
This is an implemenation of the GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/696
Work towards #25262
- - - - -
0c00c9c3 by Ben Gamari at 2025-10-15T08:06:51-04:00
rts: Eliminate uses of implicit constant arrays
Folding of `const`-sized variable-length arrays to a constant-length
array is a gnu extension which clang complains about.
Closes #26502.
- - - - -
bf902a1d by Fendor at 2025-10-15T16:00:59-04:00
Refactor distinct constructor tables map construction
Adds `GHC.Types.Unique.FM.alterUFM_L`, `GHC.Types.Unique.DFM.alterUDFM_L`
`GHC.Data.Word64Map.alterLookup` to support fusion of distinct
constructor data insertion and lookup during the construction of the `DataCon`
map in `GHC.Stg.Debug.numberDataCon`.
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
b3585ba1 by Fendor at 2025-10-15T16:00:59-04:00
Allow per constructor refinement of distinct-constructor-tables
Introduce `-fno-distinct-constructor-tables`. A distinct constructor table
configuration is built from the combination of flags given, in order. For
example, to only generate distinct constructor tables for a few specific
constructors and no others, just pass
`-fdistinct-constructor-tables-only=C1,...,CN`.
This flag can be supplied multiple times to extend the set of
constructors to generate a distinct info table for.
You can disable generation of distinct constructor tables for all
configurations by passing `-fno-distinct-constructor-tables`.
The various configurations of these flags is included in the `DynFlags`
fingerprints, which should result in the expected recompilation logic.
Adds a test that checks for distinct tables for various given or omitted
constructors.
Updates CountDepsAst and CountDepsParser tests to account for new dependencies.
Fixes #23703
Co-authored-by: Fendor <fendor(a)posteo.de>
Co-authored-by: Finley McIlwaine <finleymcilwaine(a)gmail.com>
- - - - -
e17dc695 by fendor at 2025-10-15T16:01:41-04:00
Fix typos in haddock documentation for stack annotation API
- - - - -
f85058d3 by Zubin Duggal at 2025-10-17T13:50:52+05:30
compiler: Attempt to systematize Unique tags by introducing an ADT for each different tag
Fixes #26264
Metric Decrease:
T9233
- - - - -
c85c845d by sheaf at 2025-10-17T22:35:32-04:00
Don't prematurely final-zonk PatSyn declarations
This commit makes GHC hold off on the final zonk for pattern synonym
declarations, in 'GHC.Tc.TyCl.PatSyn.tc_patsyn_finish'.
This accommodates the fact that pattern synonym declarations without a
type signature can contain unfilled metavariables, e.g. if the RHS of
the pattern synonym involves view-patterns whose type mentions promoted
(level 0) metavariables. Just like we do for ordinary function bindings,
we should allow these metavariables to be settled later, instead of
eagerly performing a final zonk-to-type.
Now, the final zonking-to-type for pattern synonyms is performed in
GHC.Tc.Module.zonkTcGblEnv.
Fixes #26465
- - - - -
ba3e5bdd by Rodrigo Mesquita at 2025-10-18T16:57:18-04:00
Move code-gen aux symbols from ghc-internal to rts
These symbols were all previously defined in ghc-internal and made the
dependency structure awkward, where the rts may refer to some of these
symbols and had to work around that circular dependency the way
described in #26166.
Moreover, the code generator will produce code that uses these symbols!
Therefore, they should be available in the rts:
PRINCIPLE: If the code generator may produce code which uses this
symbol, then it should be defined in the rts rather than, say,
ghc-internal.
That said, the main motivation is towards fixing #26166.
Towards #26166. Pre-requisite of !14892
- - - - -
f31de2a9 by Ben Gamari at 2025-10-18T16:57:18-04:00
rts: Avoid static symbol references to ghc-internal
This resolves #26166, a bug due to new constraints placed by Apple's
linker on undefined references.
One source of such references in the RTS is the many symbols referenced
in ghc-internal. To mitigate #26166, we make these references dynamic,
as described in Note [RTS/ghc-internal interface].
Fixes #26166
Co-authored-by: Rodrigo Mesquita <rodrigo.m.mesquita(a)gmail.com>
Co-authored-by: Cheng Shao <terrorjack(a)type.dance>
- - - - -
43fdfddc by Ben Gamari at 2025-10-18T16:57:18-04:00
compiler: Rename isMathFun -> isLibcFun
This set includes more than just math functions.
- - - - -
4ed5138f by Ben Gamari at 2025-10-18T16:57:18-04:00
compiler: Add libc allocator functions to libc_funs
Prototypes for these are now visible from `Prim.h`, resulting in
multiple-declaration warnings in the unregisterised job.
- - - - -
9a0a076b by Ben Gamari at 2025-10-18T16:57:18-04:00
rts: Minimize header dependencies of Prim.h
Otherwise we will end up with redundant and incompatible declarations
resulting in warnings during the unregisterised build.
- - - - -
26b8a414 by Diego Antonio Rosario Palomino at 2025-10-18T16:58:10-04:00
Cmm Parser: Fix incorrect example in comment
The Parser.y file contains a comment with an incorrect example of textual
Cmm (used in .cmm files). This commit updates the comment to ensure it
reflects valid textual Cmm syntax.
Fixes #26313
- - - - -
d4a9d6d6 by ARATA Mizuki at 2025-10-19T18:43:47+09:00
Handle implications between x86 feature flags
This includes:
* Multiple -msse* options can be specified
* -mavx implies -msse4.2
* -mavx2 implies -mavx
* -mfma implies -mavx
* -mavx512f implies -mavx2 and -mfma
* -mavx512{cd,er,pf} imply -mavx512f
Closes #24989
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
c9b8465c by Cheng Shao at 2025-10-20T10:16:00-04:00
wasm: workaround WebKit bug in dyld
This patch works around a WebKit bug and allows dyld to run on WebKit
based platforms as well. See added note for detailed explanation.
Co-authored-by: Codex <codex(a)openai.com>
- - - - -
91b6be10 by Julian Ospald at 2025-10-20T18:21:03-04:00
Improve error handling in 'getPackageArchives'
When the library dirs in the package conf files are not set up correctly,
the JS linker will happily ignore such packages and not link against them,
although they're part of the link plan.
Fixes #26383
- - - - -
6c5269da by Sven Tennie at 2025-10-20T18:21:44-04:00
Align coding style
Improve readability by using the same style for all constructor calls in
this function.
- - - - -
3d305889 by Sven Tennie at 2025-10-20T18:21:44-04:00
Reduce complexity by removing joins with mempty
ldArgs, cArgs and cppArgs are all `mempty`. Thus concatenating them adds
nothing but some complexity while reading the code.
- - - - -
38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00
Fix stack decoding when using profiled runtime
There are three fixes in this commit.
* We need to replicate the `InfoTable` and `InfoTableProf`
approach for the other stack constants (see the new Stack.ConstantsProf
file).
* Then we need to appropiately import the profiled or non-profiled
versions.
* Finally, there was an incorrect addition in `stackFrameSize`. We need
to cast after performing addition on words.
Fixes #26507
- - - - -
17231bfb by fendor at 2025-10-21T13:12:20+01:00
Add regression test for #26507
- - - - -
4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00
Postscript to fix for #26255
This MR has comments only
- - - - -
6ef22fa0 by IC Rainbow at 2025-10-26T18:23:01-04:00
Add SIMD primops for bitwise logical operations
This adds 128-bit wide and/or/xor instructions for X86 NCG,
with both SSE and AVX encodings.
```
andFloatX4# :: FloatX4# -> FloatX4# -> FloatX4# -- andps / vandps
andDoubleX2# :: DoubleX2# -> DoubleX2# -> DoubleX2# -- andpd / vandpd
andInt8X16# :: Int8X16# -> Int8X16# -> Int8X16# -- pand / vpand
```
The new primops are available on ARM when using LLVM backend.
Tests added:
- simd015 (floats and doubles)
- simd016 (integers)
- simd017 (words)
Fixes #26417
- - - - -
fbdc623a by sheaf at 2025-10-26T18:23:52-04:00
Add hints for unsolved HasField constraints
This commit adds hints and explanations for unsolved 'HasField'
constraints.
GHC will now provide additional explanations for an unsolved constraint
of the form 'HasField fld_name rec_ty fld_ty'; the details are laid out in
Note [Error messages for unsolved HasField constraints], but briefly:
1. Provide similar name suggestions (e.g. mis-spelled field name)
and import suggestions (record field not in scope).
These result in actionable 'GhcHints', which is helpful to provide
code actions in HLS.
2. Explain why GHC did not solve the constraint, e.g.:
- 'fld_name' is not a string literal (e.g. a type variable)
- 'rec_ty' is a TyCon without any fields, e.g. 'Int' or 'Bool'.
- 'fld_ty' contains existentials variables or foralls.
- The record field is a pattern synonym field (GHC does not generate
HasField instances for those).
- 'HasField' is a custom 'TyCon', not actually the built-in
'HasField' typeclass from 'GHC.Records'.
On the way, we slightly refactor the mechanisms for import suggestions
in GHC.Rename.Unbound. This is to account for the fact that, for
'HasField', we don't care whether the field is imported qualified or
unqualified. 'importSuggestions' was refactored, we now have
'sameQualImportSuggestions' and 'anyQualImportSuggestions'.
Fixes #18776 #22382 #26480
- - - - -
99d5707f by sheaf at 2025-10-26T18:23:52-04:00
Rename PatSyn MatchContext to PatSynCtx to avoid punning
- - - - -
5dc2e9ea by Julian Ospald at 2025-10-27T18:17:23-04:00
Skip uniques test if sources are not available
- - - - -
544b9ec9 by Vladislav Zavialov at 2025-10-27T18:18:06-04:00
Re-export GHC.Hs.Basic from GHC.Hs
Clean up some import sections in GHC by re-exporting GHC.Hs.Basic
from GHC.Hs.
- - - - -
643ce801 by Julian Ospald at 2025-10-28T18:18:55-04:00
rts: remove unneccesary cabal flags
We perform those checks via proper autoconf macros
instead that do the right thing and then add those
libs to the rts buildinfo.
- - - - -
d69ea8fe by Vladislav Zavialov at 2025-10-28T18:19:37-04:00
Test case for #17705
Starting with GHC 9.12 (the first release to include 5745dbd3),
all examples in this ticket are handled as expected.
- - - - -
4038a28b by Andreas Klebinger at 2025-10-30T12:38:52-04:00
Add a perf test for #26425
- - - - -
f997618e by Andreas Klebinger at 2025-10-30T12:38:52-04:00
OccAnal: Be stricter for better compiler perf.
In particular we are now stricter:
* When combining usageDetails.
* When computing binder info.
In combineUsageDetails when combining the underlying adds we compute a
new `LocalOcc` for each entry by combining the two existing ones.
Rather than wait for those entries to be forced down the road we now
force them immediately. Speeding up T26425 by about 10% with little
effect on the common case.
We also force binders we put into the Core AST everywhere now.
Failure to do so risks leaking the occ env used to set the binders
OccInfo.
For T26425 compiler residency went down by a factor of ~10x.
Compile time also improved by a factor of ~1.6.
-------------------------
Metric Decrease:
T18698a
T26425
T9233
-------------------------
- - - - -
5618645b by Vladislav Zavialov at 2025-10-30T12:39:33-04:00
Fix namespace specifiers in subordinate exports (#12488)
This patch fixes an oversight in the `lookupChildrenExport` function that
caused explicit namespace specifiers of subordinate export items to be
ignored:
module M (T (type A)) where -- should be rejected
data T = A
Based on the `IEWrappedName` data type, there are 5 cases to consider:
1. Unadorned name: P(X)
2. Named default: P(default X)
3. Pattern synonym: P(pattern X)
4. Type name: P(type X)
5. Data name: P(data X)
Case 1 is already handled correctly; cases 2 and 3 are parse errors; and
it is cases 4 and 5 that we are concerned with in this patch.
Following the precedent established in `LookupExactName`, we introduce
a boolean flag in `LookupChildren` to control whether to look up in all
namespaces or in a specific one. If an export item is accompanied by an
explicit namespace specifier `type` or `data`, we restrict the lookup in
`lookupGRE` to a specific namespace.
The newly introduced diagnostic `TcRnExportedSubordinateNotFound`
provides error messages and suggestions more tailored to this context
than the previously used `reportUnboundName`.
- - - - -
f75ab223 by Peter Trommler at 2025-10-31T18:43:13-04:00
ghc-toolchain: detect PowerPC 64 bit ABI
Check preprocessor macro defined for ABI v2 and assume v1 otherwise.
Fixes #26521
- - - - -
d086c474 by Peter Trommler at 2025-10-31T18:43:13-04:00
ghc-toolchain: refactor, move lastLine to Utils
- - - - -
995dfe0d by Vladislav Zavialov at 2025-10-31T18:43:54-04:00
Tests for -Wduplicate-exports, -Wdodgy-exports
Add test cases for the previously untested diagnostics:
[GHC-51876] TcRnDupeModuleExport
[GHC-64649] TcRnNullExportedModule
This also revealed a typo (incorrect capitalization of "module") in the
warning text for TcRnDupeModuleExport, which is now fixed.
- - - - -
f6961b02 by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: reformat dyld source code
This commit reformats dyld source code with prettier, to avoid
introducing unnecessary diffs in subsequent patches when they're
formatted before committing.
- - - - -
0c9032a0 by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: simplify _initialize logic in dyld
This commit simplifies how we _initialize a wasm shared library in
dyld and removes special treatment for libc.so, see added comment for
detailed explanation.
- - - - -
ec1b40bd by Cheng Shao at 2025-11-01T00:08:01+01:00
wasm: support running dyld fully client side in the browser
This commit refactors the wasm dyld script so that it can be used to
load and run wasm shared libraries fully client-side in the browser
without needing a wasm32-wasi-ghci backend:
- A new `DyLDBrowserHost` class is exported, which runs in the browser
and uses the in-memory vfs without any RPC calls. This meant to be
used to create a `rpc` object for the fully client side use cases.
- The exported `main` function now can be used to load user-specified
shared libraries, and the user can use the returned `DyLD` instance
to run their own exported Haskell functions.
- The in-browser wasi implementation is switched to
https://github.com/haskell-wasm/browser_wasi_shim for bugfixes and
major performance improvements not landed upstream yet.
- When being run by deno, it now correctly switches to non-nodejs code
paths, so it's more convenient to test dyld logic with deno.
See added comments for details, as well as the added `playground001`
test case for an example of using it to build an in-browser Haskell
playground.
- - - - -
8f3e481f by Cheng Shao at 2025-11-01T00:08:01+01:00
testsuite: add playground001 to test haskell playground
This commit adds the playground001 test case to test the haskell
playground in browser, see comments for details.
- - - - -
af40606a by Cheng Shao at 2025-11-01T00:08:04+01:00
Revert "testsuite: add T26431 test case"
This reverts commit 695036686f8c6d78611edf3ed627608d94def6b7. T26431
is now retired, wasm ghc internal-interpreter logic is tested by
playground001.
- - - - -
86c82745 by Vladislav Zavialov at 2025-11-01T07:24:29-04:00
Supplant TcRnExportHiddenComponents with TcRnDodgyExports (#26534)
Remove a bogus special case in lookup_ie_kids_all,
making TcRnExportHiddenComponents obsolete.
- - - - -
fcf6331e by Richard Eisenberg at 2025-11-03T08:33:05+00:00
Refactor fundep solving
This commit is a large-scale refactor of the increasingly-messy code that
handles functional dependencies. It has virtually no effect on what compiles
but improves error messages a bit. And it does the groundwork for #23162.
The big picture is described in
Note [Overview of functional dependencies in type inference]
in GHC.Tc.Solver.FunDeps
* New module GHC.Tc.Solver.FunDeps contains all the fundep-handling
code for the constraint solver.
* Fundep-equalities are solved in a nested scope; they may generate
unifications but otherwise have no other effect.
See GHC.Tc.Solver.FunDeps.solveFunDeps
The nested needs to start from the Givens in the inert set, but
not the Wanteds; hence a new function `resetInertCans`, used in
`nestFunDepsTcS`.
* That in turn means that fundep equalities never show up in error
messages, so the complicated FunDepOrigin tracking can all disappear.
* We need to be careful about tracking unifications, so we kick out
constraints from the inert set after doing unifications. Unification
tracking has been majorly reformed: see Note [WhatUnifications] in
GHC.Tc.Utils.Unify.
A good consequence is that the hard-to-grok `resetUnificationFlag`
has been replaced with a simpler use of
`reportCoarseGrainUnifications`
Smaller things:
* Rename `FunDepEqn` to `FunDepEqns` since it contains multiple
type equalities.
Some compile time improvement
Metrics: compile_time/bytes allocated
Baseline
Test value New value Change
---------------------- --------------------------------------
T5030(normal) 173,839,232 148,115,248 -14.8% GOOD
hard_hole_fits(normal) 286,768,048 284,015,416 -1.0%
geo. mean -0.2%
minimum -14.8%
maximum +0.3%
Metric Decrease:
T5030
- - - - -
231adc30 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
QuickLook's tcInstFun should make instantiation variables directly
tcInstFun must make "instantiation variables", not regular
unification variables, when instantiating function types. That was
previously implemented by a hack: set the /ambient/ level to QLInstTyVar.
But the hack finally bit me, when I was refactoring WhatUnifications.
And it was always wrong: see the now-expunged (TCAPP2) note.
This commit does it right, by making tcInstFun call its own
instantiation functions. That entails a small bit of duplication,
but the result is much, much cleaner.
- - - - -
39d4a24b by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Build implication for constraints from (static e)
This commit addresses #26466, by buiding an implication for the
constraints arising from a (static e) form. The implication has
a special ic_info field of StaticFormSkol, which tells the constraint
solver to use an empty set of Givens.
See (SF3) in Note [Grand plan for static forms]
in GHC.Iface.Tidy.StaticPtrTable
This commit also reinstates an `assert` in GHC.Tc.Solver.Equality.
The test `StaticPtrTypeFamily` was failing with an assertion failure,
but it now works.
- - - - -
2e2aec1e by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Comments about defaulting representation equalities
- - - - -
52a4d1da by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Improve tracking of rewriter-sets
This refactor substantially improves the treatment of so-called
"rewriter-sets" in the constraint solver.
The story is described in the rewritten
Note [Wanteds rewrite Wanteds: rewriter-sets]
in GHC.Tc.Types.Constraint
Some highlights
* Trace the free coercion holes of a filled CoercionHole,
in CoercionPlusHoles. See Note [Coercion holes] (COH5)
This avoids taking having to take the free coercion variables
of a coercion when zonking a rewrriter-set
* Many knock on changes
* Make fillCoercionHole take CoercionPlusHoles as its argument
rather than to separate arguments.
* Similarly setEqIfWanted, setWantedE, wrapUnifierAndEmit.
* Be more careful about passing the correct CoHoleSet to
`rewriteEqEvidence` and friends
* Make kickOurAfterFillingCoercionHole more clever. See
new Note [Kick out after filling a coercion hole]
Smaller matters
* Rename RewriterSet to CoHoleSet
* Add special-case helper `rewriteEqEvidenceSwapOnly`
- - - - -
3e78e1ba by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Tidy up constraint solving for foralls
* In `can_eq_nc_forall` make sure to track Givens that are used
in the nested solve step.
* Tiny missing-swap bug-fix in `lookup_eq_in_qcis`
* Fix some leftover mess from
commit 14123ee646f2b9738a917b7cec30f9d3941c13de
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Wed Aug 20 00:35:48 2025 +0100
Solve forall-constraints via an implication, again
Specifically, trySolveImplication is now dead.
- - - - -
973f2c25 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Do not treat CoercionHoles as free variables in coercions
This fixes a long-standing wart in the free-variable finder;
now CoercionHoles are no longer treated as a "free variable"
of a coercion.
I got big and unexpected performance regressions when making
this change. Turned out that CallArity didn't discover that
the free variable finder could be eta-expanded, which gave very
poor code.
So I re-used Note [The one-shot state monad trick] for Endo,
resulting in GHC.Utils.EndoOS. Very simple, big win.
- - - - -
c2b8a0f9 by Simon Peyton Jones at 2025-11-03T08:33:05+00:00
Update debug-tracing in CallArity
No effect on behaviour, and commented out anyway
- - - - -
9aa5ee99 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00
Comments only -- remove dangling Note references
- - - - -
6683f183 by Simon Peyton Jones at 2025-11-03T08:33:28+00:00
Accept error message wibbles
- - - - -
3ba3d9f9 by Luite Stegeman at 2025-11-04T00:59:41-05:00
rts: fix eager black holes: record mutated closure and fix assertion
This fixes two problems with handling eager black holes, introduced
by a1de535f762bc23d4cf23a5b1853591dda12cdc9.
- the closure mutation must be recorded even for eager black holes,
since the mutator has mutated it before calling threadPaused
- The assertion that an unmarked eager black hole must be owned by
the TSO calling threadPaused is incorrect, since multiple threads
can race to claim the black hole.
fixes #26495
- - - - -
b5508f2c by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
build: Relax ghc/ghc-boot Cabal bound to 3.16
Fixes #26202
- - - - -
c5b3541f by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
cabal-reinstall: Use haddock-api +in-tree-ghc
Fixes #26202
- - - - -
c6d4b945 by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
cabal-reinstall: Pass --strict to Happy
This is necessary to make the generated Parser build successfully
This mimics Hadrian, which always passes --strict to happy.
Fixes #26202
- - - - -
79df1e0e by Rodrigo Mesquita at 2025-11-04T14:10:56+00:00
genprimopcode: Require higher happy version
I've bumped the happy version to forbid deprecated Happy versions which
don't successfully compile.
- - - - -
fa5d33de by Simon Peyton Jones at 2025-11-05T08:35:40-05:00
Add a HsWrapper optimiser
This MR addresses #26349, by introduceing optSubTypeHsWrapper.
There is a long
Note [Deep subsumption and WpSubType]
in GHC.Tc.Types.Evidence that explains what is going on.
- - - - -
ea58cae5 by Simon Peyton Jones at 2025-11-05T08:35:40-05:00
Improve mkWpFun_FRR
This commit ensures that `mkWpFun_FRR` directly produces a `FunCo` in
the cases where it can.
(Previously called `mkWpFun` which in turn optimised to a `FunCo`, but
that made the smarts in `mkWpFun` /essential/ rather than (as they
should be) optional.
- - - - -
5cdcfaed by Ben Gamari at 2025-11-06T09:01:36-05:00
compiler: Exclude units with no exposed modules from unused package check
Such packages cannot be "used" in the Haskell sense of the word yet
are nevertheless necessary as they may provide, e.g., C object code or
link flags.
Fixes #24120.
- - - - -
74b8397a by Brandon Chinn at 2025-11-06T09:02:19-05:00
Replace deprecated argparse.FileType
- - - - -
36ddf988 by Ben Gamari at 2025-11-06T09:03:01-05:00
Bump unix submodule to 2.8.8.0
Closes #26474.
- - - - -
c32b3a29 by fendor at 2025-11-06T09:03:43-05:00
Fix assertion in `postStringLen` to account for \0 byte
We fix the assertion to handle trailing \0 bytes in `postStringLen`.
Before this change, the assertion looked like this:
ASSERT(eb->begin + eb->size > eb->pos + len + 1);
Let's assume some values to see why this is actually off by one:
eb->begin = 0
eb->size = 1
eb->pos = 0
len = 1
then the assertion would trigger correctly:
0 + 1 > 0 + 1 + 1 => 1 > 2 => false
as there is not enough space for the \0 byte (which is the trailing +1).
However, if we change `eb->size = 2`, then we do have enough space for a
string of length 1, but the assertion still fails:
0 + 2 > 0 + 1 + 1 => 2 > 2 => false
Which causes the assertion to fail if there is exactly enough space for
the string with a trailing \0 byte.
Clearly, the assertion should be `>=`!
If we switch around the operand, it should become more obvious that `<=`
is the correct comparison:
ASSERT(eb->pos + len + 1 <= eb->begin + eb->size);
This is expresses more naturally that the current position plus the
length of the string (and the null byte) must be smaller or equal to the
overall size of the buffer.
This change also is in line with the implementation in
`hasRoomForEvent` and `hasRoomForVariableEvent`:
```
StgBool hasRoomForEvent(EventsBuf *eb, EventTypeNum eNum)
{
uint32_t size = ...;
if (eb->pos + size > eb->begin + eb->size)
...
```
the check `eb->pos + size > eb->begin + eb->size` is identical to
`eb->pos + size <= eb->begin + eb->size` plus a negation.
- - - - -
3034a6f2 by Ben Gamari at 2025-11-06T09:04:24-05:00
Bump os-string submodule to 2.0.8
- - - - -
39567e85 by Cheng Shao at 2025-11-06T09:05:06-05:00
rts: use computed goto for instruction dispatch in the bytecode interpreter
This patch uses computed goto for instruction dispatch in the bytecode
interpreter. Previously instruction dispatch is done by a classic
switch loop, so executing the next instruction requires two jumps: one
to the start of the switch loop and another to the case block based on
the instruction tag. By using computed goto, we can build a jump table
consisted of code addresses indexed by the instruction tags
themselves, so executing the next instruction requires only one jump,
to the destination directly fetched from the jump table.
Closes #12953.
- - - - -
93fc7265 by sheaf at 2025-11-06T21:33:24-05:00
Correct hasFixedRuntimeRep in matchExpectedFunTys
This commit fixes a bug in the representation-polymormorphism check in
GHC.Tc.Utils.Unify.matchExpectedFunTys. The problem was that we put
the coercion resulting from hasFixedRuntimeRep in the wrong place,
leading to the Core Lint error reported in #26528.
The change is that we have to be careful when using 'mkWpFun': it
expects **both** the expected and actual argument types to have a
syntactically fixed RuntimeRep, as explained in Note [WpFun-FRR-INVARIANT]
in GHC.Tc.Types.Evidence.
On the way, this patch improves some of the commentary relating to
other usages of 'mkWpFun' in the compiler, in particular in the view
pattern case of 'tc_pat'. No functional changes, but some stylistic
changes to make the code more readable, and make it easier to understand
how we are upholding the WpFun-FRR-INVARIANT.
Fixes #26528
- - - - -
c052c724 by Simon Peyton Jones at 2025-11-06T21:34:06-05:00
Fix a horrible shadowing bug in implicit parameters
Fixes #26451. The change is in GHC.Tc.Solver.Monad.updInertDicts
where we now do /not/ delete /Wanted/ implicit-parameeter constraints.
This bug has been in GHC since 9.8! But it's quite hard to provoke;
I contructed a tests in T26451, but it was hard to do so.
- - - - -
b253013e by Georgios Karachalias at 2025-11-07T17:21:57-05:00
Remove the `CoreBindings` constructor from `LinkablePart`
Adjust HscRecompStatus to disallow unhydrated WholeCoreBindings
from being passed as input to getLinkDeps (which would previously
panic in this case).
Fixes #26497
- - - - -
ac7b737e by Sylvain Henry at 2025-11-07T17:22:51-05:00
Testsuite: pass ext-interp test way (#26552)
Note that some tests are still marked as broken with the ext-interp way
(see #26552 and #14335)
- - - - -
3c2f4bb4 by sheaf at 2025-11-11T11:47:28-05:00
Preserve user-written kinds in data declarations
This commit ensures that we preserve the user-written kind for data
declarations, e.g. in
type T2T = Type -> Type
type D :: T2T
data D a where { .. }
that we preserve the user-written kind of D as 'T2T', instead of
expanding the type synonym 'T2T' during kind checking.
We do this by storing 'tyConKind' separately from 'tyConResKind'. This
means that 'tyConKind' is not necessarily equal to
'mkTyConKind binders res_kind', as e.g. in the above example the former
is 'T2T' while the latter is 'Type -> Type'.
This is explained in Note [Preserve user-written TyCon kind] in GHC.Core.TyCon.
This is particularly important for Haddock, as the kinds stored in
interface files affect the generated documentation, and we want to
preserve the user-written types as much as possible.
- - - - -
19859584 by sheaf at 2025-11-11T11:47:28-05:00
Store user-written datacon tvs in interface files
This commit ensures we store the user-written quantified type variables
of data constructors in interface files, e.g. in
data D a where
MkD1 :: forall x. x -> D x
MkD2 :: forall u v. u -> v -> D v
The previous behaviour was to rename the universal variables to match
the universal variables of the data constructor. This was undesirable
because the names that end up in interface files end up mattering for
generated Haddock documentation; it's better to preserve the user-written
type variables.
Moreover, the universal variables may not have been user-written at all,
e.g. in an example such as:
type T2T = Type -> Type
data G :: T2T where
MkG :: forall x. D x
Here GHC will invent the type variable name 'a' for the first binder of
the TyCon G. We really don't want to then rename the user-written 'x'
into the generated 'a'.
- - - - -
034b2056 by sheaf at 2025-11-11T11:47:28-05:00
DataCon univ_tvs names: pick TyCon over inferred
This commit changes how we compute the names of universal type variables
in GADT data constructors. This augments the existing logic that chose
which type variable name to use, in GHC.Tc.TyCl.mkGADTVars. We continue
to prefer DataCon tv names for user-written binders, but we now prefer
TyCon tv names for inferred (non-user-written) DataCon binders.
This makes a difference in examples such as:
type (:~~:) :: k1 -> k2 -> Type
data a :~~: b where
HRefl :: a :~~: a
Before this patch, we ended up giving HRefl the type:
forall {k2}. forall (a :: k2). a :~~: a
whereas we now give it the type:
forall {k1}. forall (a :: k1). a :~~: a
The important part isn't really 'k1' or 'k2', but more that the inferred
type variable names of the DataCon can be arbitrary/unpredictable (as
they are chosen by GHC and depend on how unification proceeds), so it's
much better to use the more predictable TyCon type variable names.
- - - - -
95078d00 by sheaf at 2025-11-11T11:47:28-05:00
Backpack Rename: use explicit record construction
This commit updates the Backpack boilerplate in GHC.Iface.Rename to
use explicit record construction rather than record update. This makes
sure that the code stays up to date when the underlying constructors
change (e.g. new fields are added). The rationale is further explained
in Note [Prefer explicit record construction].
- - - - -
2bf36263 by sheaf at 2025-11-11T11:47:28-05:00
Store # eta binders in TyCon and use for Haddock
This commit stores the number of TyCon binders that were introduced by
eta-expansion (by the function GHC.Tc.Gen.HsType.splitTyConKind).
This is then used to pretty-print the TyCon as the user wrote it, e.g.
for
type Effect :: (Type -> Type) -> Type -> Type
data State s :: Effect where {..} -- arity 3
GHC will eta-expand the data declaration to
data State s a b where {..}
but also store in the 'TyCon' that the number of binders introduced by
this eta expansion is 2. This allows us, in
'Haddock.Convert.synifyTyConKindSig', to recover the original user-written
syntax, preserving the user's intent in Haddock documentation.
See Note [Inline kind signatures with GADTSyntax] in Haddock.Convert.
- - - - -
6c91582f by Matthew Pickering at 2025-11-11T11:48:12-05:00
driver: Properly handle errors during LinkNode steps
Previously we were not properly catching errors during the LinkNode step
(see T9930fail test).
This is fixed by wrapping the `LinkNode` action in `wrapAction`, the
same handler which is used for module compilation.
Fixes #26496
- - - - -
e1e1eb32 by Matthew Pickering at 2025-11-11T11:48:54-05:00
driver: Remove unecessary call to hscInsertHPT
This call was left-over from e9445c013fbccf9318739ca3d095a3e0a2e1be8a
If you follow the functions which call `upsweep_mod`, they immediately
add the interface to the HomePackageTable when `upsweep_mod` returns.
- - - - -
b22777d4 by ARATA Mizuki at 2025-11-11T11:49:44-05:00
LLVM backend: Pass the +evex512 attribute to LLVM 18+ if -mavx512f is set
The newer LLVM requires the +evex512 attribute to enable use of ZMM registers.
LLVM exhibits a backward-compatible behavior if the cpu is `x86-64`, but not if `penryn`.
Therefore, on macOS, where the cpu is set to `penryn`, we need to explicitly pass +evex512.
Fixes #26410
- - - - -
6ead7d06 by Vladislav Zavialov at 2025-11-11T11:50:26-05:00
Comments only in GHC.Parser.PostProcess.Haddock
Remove outdated Note [Register keyword location], as the issue it describes
was addressed by commit 05eb50dff2fcc78d025e77b9418ddb369db49b9f.
- - - - -
43fa8be8 by sheaf at 2025-11-11T11:51:18-05:00
localRegistersConflict: account for assignment LHS
This commit fixes a serious oversight in GHC.Cmm.Sink.conflicts,
specifically the code that computes which local registers conflict
between an assignment and a Cmm statement.
If we have:
assignment: <local_reg> = <expr>
node: <local_reg> = <other_expr>
then clearly the two conflict, because we cannot move one statement past
the other, as they assign two different values to the same local
register. (Recall that 'conflicts (local_reg,expr) node' is False if and
only if the assignment 'local_reg = expr' can be safely commuted past
the statement 'node'.)
The fix is to update 'GHC.Cmm.Sink.localRegistersConflict' to take into
account the following two situations:
(1) 'node' defines the LHS local register of the assignment,
(2) 'node' defines a local register used in the RHS of the assignment.
The bug is precisely that we were previously missing condition (1).
Fixes #26550
- - - - -
79dfcfe0 by sheaf at 2025-11-11T11:51:18-05:00
Update assigned register format when spilling
When we come to spilling a register to put new data into it, in
GHC.CmmToAsm.Reg.Linear.allocRegsAndSpill_spill, we need to:
1. Spill the data currently in the register. That is, do a spill
with a format that matches what's currently in the register.
2. Update the register assignment, allocating a virtual register to
this real register, but crucially **updating the format** of this
assignment.
Due to shadowing in the Haskell code for allocRegsAndSpill_spill, we
were mistakenly re-using the old format. This could lead to a situation
where:
a. We were using xmm6 to store a Double#.
b. We want to store a DoubleX2# into xmm6, so we spill the current
content of xmm6 to the stack using a scalar move (correct).
c. We update the register assignment, but we fail to update the format
of the assignment, so we continue to think that xmm6 stores a
Double# and not a DoubleX2#.
d. Later on, we need to spill xmm6 because it is getting clobbered by
another instruction. We then decide to only spill the lower 64 bits
of the register, because we still think that xmm6 only stores a
Double# and not a DoubleX2#.
Fixes #26542
- - - - -
aada5db9 by ARATA Mizuki at 2025-11-11T11:52:07-05:00
Fix the order of spill/reload instructions
The AArch64 NCG could emit multiple instructions for a single spill/reload,
but their order was not consistent between the definition and a use.
Fixes #26537
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
64ec82ff by Andreas Klebinger at 2025-11-11T11:52:48-05:00
Add hpc to release script
- - - - -
741da00c by Ben Gamari at 2025-11-12T03:38:20-05:00
template-haskell: Better describe getQ semantics
Clarify that the state is a type-indexed map, as suggested by #26484.
- - - - -
8b080e04 by ARATA Mizuki at 2025-11-12T03:39:11-05:00
Fix incorrect markups in the User's Guide
* Correct markup for C--: "C-\-" in reST
* Fix internal links
* Fix code highlighting
* Fix inline code: Use ``code`` rather than `code`
* Remove extra backslashes
Fixes #16812
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
a00840ea by Simon Peyton Jones at 2025-11-14T15:23:56+00:00
Make TYPE and CONSTRAINT apart again
This patch finally fixes #24279.
* The story started with #11715
* Then #21623 articulated a plan, which made Type and Constraint
not-apart; a horrible hack but it worked. The main patch was
commit 778c6adca2c995cd8a1b84394d4d5ca26b915dac
Author: Simon Peyton Jones <simonpj(a)microsoft.com>
Date: Wed Nov 9 10:33:22 2022 +0000
Type vs Constraint: finally nailed
* #24279 reported a bug in the above big commit; this small patch fixes it
commit af6932d6c068361c6ae300d52e72fbe13f8e1f18
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Jan 8 10:49:49 2024 +0000
Make TYPE and CONSTRAINT not-apart
Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty
which is supposed to make TYPE and CONSTRAINT be not-apart.
* Then !10479 implemented "unary classes".
* That change in turn allows us to make Type and Constraint apart again,
cleaning up the compiler and allowing a little bit more expressiveness.
It fixes the original hope in #24279, namely that `Type` and `Constraint`
should be distinct throughout.
- - - - -
c0a1e574 by Georgios Karachalias at 2025-11-15T05:14:31-05:00
Report all missing modules with -M
We now report all missing modules at once in GHC.Driver.Makefile.processDeps,
as opposed to only reporting a single missing module. Fixes #26551.
- - - - -
c9fa3449 by Sylvain Henry at 2025-11-15T05:15:26-05:00
JS: fix array index for registers
We used to store R32 in h$regs[-1]. While it's correct in JavaScript,
fix this to store R32 in h$regs[0] instead.
- - - - -
9e469909 by Sylvain Henry at 2025-11-15T05:15:26-05:00
JS: support more than 128 registers (#26558)
The JS backend only supported 128 registers (JS variables/array slots
used to pass function arguments). It failed in T26537 when 129
registers were required.
This commit adds support for more than 128 registers: it is now limited to
maxBound :: Int (compiler's Int). If we ever go above this threshold the
compiler now panics with a more descriptive message.
A few built-in JS functions were assuming 128 registers and have been
rewritten to use loops. Note that loops are only used for "high"
registers that are stored in an array: the 31 "low" registers are still
handled with JS global variables and with explicit switch-cases to
maintain good performance in the most common cases (i.e. few registers
used). Adjusting the number of low registers is now easy: just one
constant to adjust (GHC.StgToJS.Regs.lowRegsCount).
No new test added: T26537 is used as a regression test instead.
- - - - -
0a64a78b by Sven Tennie at 2025-11-15T20:31:10-05:00
AArch64: Simplify CmmAssign and CmmStore
The special handling for floats was fake: The general case is always
used. So, the additional code path isn't needed (and only adds
complexity for the reader.)
- - - - -
15b311be by sheaf at 2025-11-15T20:32:02-05:00
SimpleOpt: refactor & push coercions into lambdas
This commit improves the simple optimiser (in GHC.Core.SimpleOpt)
in a couple of ways:
- The logic to push coercion lambdas is shored up.
The function 'pushCoercionIntoLambda' used to be called in 'finish_app',
but this meant we could not continue to optimise the program after
performing this transformation.
Now, we call 'pushCoercionIntoLambda' as part of 'simple_app'.
Doing so can be important when dealing with unlifted newtypes,
as explained in Note [Desugaring unlifted newtypes].
- The code is re-structured to avoid duplication and out-of-sync
code paths.
Now, 'simple_opt_expr' defers to 'simple_app' for the 'App', 'Var',
'Cast' and 'Lam' cases. This means all the logic for those is
centralised in a single place (e.g. the 'go_lam' helper function).
To do this, the general structure is brought a bit closer to the
full-blown simplifier, with a notion of 'continuation'
(see 'SimpleContItem').
This commit also modifies GHC.Core.Opt.Arity.pushCoercionIntoLambda to
apply a substitution (a slight generalisation of its existing implementation).
- - - - -
b33284c7 by sheaf at 2025-11-15T20:32:02-05:00
Improve typechecking of data constructors
This commit changes the way in which we perform typecheck data
constructors, in particular how we make multiplicities line up.
Now, impedance matching occurs as part of the existing subsumption
machinery. See the revamped Note [Typechecking data constructors] in
GHC.Tc.Gen.App, as well as Note [Polymorphisation of linear fields]
in GHC.Core.Multiplicity.
This allows us to get rid of a fair amount of hacky code that was
added with the introduction of LinearTypes; in particular the logic of
GHC.Tc.Gen.Head.tcInferDataCon.
-------------------------
Metric Decrease:
T10421
T14766
T15164
T15703
T19695
T5642
T9630
WWRec
-------------------------
- - - - -
b6faf5d0 by sheaf at 2025-11-15T20:32:02-05:00
Handle unsaturated rep-poly newtypes
This commit allows GHC to handle unsaturated occurrences of unlifted
newtype constructors. The plan is detailed in
Note [Eta-expanding rep-poly unlifted newtypes]
in GHC.Tc.Utils.Concrete: for unsaturated unlifted newtypes, we perform
the appropriate representation-polymorphism check in tcInstFun.
- - - - -
682bf979 by Mike Pilgrem at 2025-11-16T16:44:14+00:00
Fix #26293 Valid stack.yaml for hadrian
- - - - -
acc70c3a by Simon Peyton Jones at 2025-11-18T16:21:20-05:00
Fix a bug in defaulting
Addresses #26582
Defaulting was doing some unification but then failing to
iterate. Silly.
I discovered that the main solver was unnecessarily iterating even
if there was a unification for an /outer/ unification variable, so
I fixed that too.
- - - - -
c12fa73e by Simon Peyton Jones at 2025-11-19T02:55:01-05:00
Make PmLit be in Ord, and use it in Map
This MR addresses #26514, by changing from
data PmAltConSet = PACS !(UniqDSet ConLike) ![PmLit]
to
data PmAltConSet = PACS !(UniqDSet ConLike) !(Map PmLit PmLit)
This matters when doing pattern-match overlap checking, when there
is a very large set of patterns. For most programs it makes
no difference at all.
For the N=5000 case of the repro case in #26514, compiler
mutator time (with `-fno-code`) goes from 1.9s to 0.43s.
All for the price for an Ord instance for PmLit
- - - - -
41b84f40 by sheaf at 2025-11-19T02:55:52-05:00
Add passing tests for #26311 and #26072
This commit adds two tests cases that now pass since landing the changes
to typechecking of data constructors in b33284c7.
Fixes #26072 #26311
- - - - -
1faa758a by sheaf at 2025-11-19T02:55:52-05:00
mkCast: weaken bad cast warning for multiplicity
This commit weakens the warning message emitted when constructing a bad
cast in mkCast to ignore multiplicity.
Justification: since b33284c7, GHC uses sub-multiplicity coercions to
typecheck data constructors. The coercion optimiser is free to discard
these coercions, both for performance reasons, and because GHC's Core
simplifier does not (yet) preserve linearity.
We thus weaken 'mkCast' to use 'eqTypeIgnoringMultiplicity' instead of
'eqType', to avoid getting many spurious warnings about mismatched
multiplicities.
- - - - -
55eab80d by Sylvain Henry at 2025-11-20T17:33:13-05:00
Build external interpreter program on demand (#24731)
This patch teaches GHC how to build the external interpreter program
when it is missing. As long as we have the `ghci` library, doing this is
trivial so most of this patch is refactoring for doing it sanely.
- - - - -
08bbc028 by Rodrigo Mesquita at 2025-11-20T17:33:54-05:00
Add tests for #23973 and #26565
These were fixed by 4af4f0f070f83f948e49ad5d7835fd91b8d3f0e6 in !10417
- - - - -
6b42232c by sheaf at 2025-11-20T17:34:35-05:00
Mark T26410_ffi as fragile on Windows
As seen in #26595, this test intermittently fails on Windows.
This commit marks it as fragile, until we get around to fixing it.
- - - - -
b7b7c049 by Andrew Lelechenko at 2025-11-21T21:04:01+00:00
Add nubOrd / nubOrdBy to Data.List and Data.List.NonEmpty
As per https://github.com/haskell/core-libraries-committee/issues/336
- - - - -
352d5462 by Marc Scholten at 2025-11-22T10:33:03-05:00
Fix haddock test runner to handle UTF-8 output
xhtml 3000.4.0.0 now produces UTF-8 output instead of escaping non-ASCII characters.
When using --test-accept it previously wrote files in the wrong encoding
because they have not been decoded properly when reading the files.
- - - - -
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
- - - - -
d4b1e353 by Simon Hengel at 2025-12-10T00:00:02-05:00
Fix syntax error in gadt_syntax.rst
- - - - -
91cc8be6 by Cheng Shao at 2025-12-10T00:00:43-05:00
ci: fix "ci.sh clean" to address frequent out of space error on windows runners
This patch fixes the `ci.sh clean` logic to address frequent out of
space error on windows runners; previously it didn't clean up the
inplace mingw blobs, which is the largest source of space leak on
windows runners. See added comment for detailed explanation.
- - - - -
fe2b79f4 by Recursion Ninja at 2025-12-10T08:34:18-05:00
Narrow before optimising MUL/DIV/REM into shifts
The MUL/DIV/REM operations can be optimised into shifts when one of the
operands is a constant power of 2. However, as literals in Cmm are
stored as 'Integer', for this to be correct we first need to narrow the
literal to the appropriate width before checking whether the literal is
a power of 2.
Fixes #25664
- - - - -
06c2349c by Recursion Ninja at 2025-12-10T08:34:58-05:00
Decouple 'Language.Haskell.Syntax.Type' from 'GHC.Utils.Panic'
- Remove the *original* defintion of 'hsQTvExplicit' defined within 'Language.Haskell.Syntax.Type'
- Redefine 'hsQTvExplicit' as 'hsq_explicit' specialized to 'GhcPass' exported by 'GHC.Utils.Panic'
- Define 'hsQTvExplicitBinders' as 'hsq_explicit' specialized to 'DocNameI' exported by 'Haddock.GhcUtils'.
- Replace all call sites of the original 'hsQTvExplicit' definition with either:
1. 'hsQTvExplicit' updated definition
2. 'hsQTvExplicitBinders'
All call sites never entered the 'XLHsQTyVars' constructor branch, but a call to 'panic' existed on this code path because the type system was not strong enought to guarantee that the 'XLHsQTyVars' construction was impossible.
These two specialized functions provide the type system with enough information to make that guarantee, and hence the dependancy on 'panic' can be removed.
- - - - -
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
984635c0 by Wolfgang Jeltsch at 2025-12-11T20:22:31+02:00
Add operations for obtaining operating-system handles
This resolves #26265.
- - - - -
986 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/upload_ghc_libs.py
- .gitmodules
- cabal.project-reinstall
- compile_flags.txt
- compiler/GHC.hs
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Builtin/Types/Literals.hs
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Builtin/Uniques.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Breakpoints.hs
- compiler/GHC/ByteCode/Linker.hs
- + compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/Cmm/MachOp.hs
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Pipeline.hs
- compiler/GHC/Cmm/Sink.hs
- compiler/GHC/Cmm/UniqueRenamer.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/RegInfo.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/LA64/CodeGen.hs
- compiler/GHC/CmmToAsm/PPC/RegInfo.hs
- compiler/GHC/CmmToAsm/Reg/Linear.hs
- compiler/GHC/CmmToAsm/Reg/Liveness.hs
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/CmmToC.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/ConLike.hs
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Multiplicity.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/CallArity.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/PatSyn.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/RoughMap.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Ppr.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCon.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Data/FlatBag.hs
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Data/SmallArray.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/Backend/Internal.hs
- compiler/GHC/Driver/Backpack.hs
- + compiler/GHC/Driver/ByteCode.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/Config/Finder.hs
- + compiler/GHC/Driver/Config/Interpreter.hs
- compiler/GHC/Driver/Config/Linker.hs
- compiler/GHC/Driver/Config/Stg/Debug.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Errors.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/MakeFile.hs
- compiler/GHC/Driver/Messager.hs
- compiler/GHC/Driver/Monad.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/Plugins.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Hs.hs
- compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Foreign/C.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/HsToCore/Foreign/Wasm.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/HsToCore/Pmc/Utils.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Flags.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp/Flags.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/JS/JStg/Monad.hs
- + compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Config.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Dynamic.hs
- + compiler/GHC/Linker/Executable.hs
- − compiler/GHC/Linker/ExtraObj.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/MacOS.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Linker/Windows.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/Header.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Platform.hs
- compiler/GHC/Platform/Reg.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Interpreter.hs
- + compiler/GHC/Runtime/Interpreter/C.hs
- + compiler/GHC/Runtime/Interpreter/Init.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- compiler/GHC/Settings.hs
- compiler/GHC/Stg/Debug.hs
- + compiler/GHC/Stg/Debug/Types.hs
- compiler/GHC/Stg/EnforceEpt.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/StgToCmm/ExtCode.hs
- compiler/GHC/StgToCmm/Monad.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Ids.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/StgToJS/Regs.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Rts/Types.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Instance/FunDeps.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- + compiler/GHC/Tc/Solver/FunDeps.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Irred.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Solver/Solve.hs-boot
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/TyCl/Build.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Types/CtLoc.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Concrete.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Utils/Unify.hs-boot
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/ThToHs.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/Id/Make.hs
- compiler/GHC/Types/Name/Cache.hs
- compiler/GHC/Types/Name/Reader.hs
- compiler/GHC/Types/SourceError.hs
- compiler/GHC/Types/SourceText.hs
- compiler/GHC/Types/SptEntry.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Types/TyThing/Ppr.hs
- compiler/GHC/Types/Unique.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/DSM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Unique/Set.hs
- compiler/GHC/Types/Unique/Supply.hs
- compiler/GHC/Types/Var/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Home/PackageTable.hs
- compiler/GHC/Unit/Info.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModSummary.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Binary.hs
- + compiler/GHC/Utils/EndoOS.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- compiler/Language/Haskell/Syntax/Type.hs
- compiler/Setup.hs
- compiler/cbits/keepCAFsForGHCi.c
- compiler/ghc.cabal.in
- configure.ac
- distrib/configure.ac.in
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/bugs.rst
- docs/users_guide/compare-flags.py
- docs/users_guide/conf.py
- docs/users_guide/debug-info.rst
- docs/users_guide/debugging.rst
- docs/users_guide/extending_ghc.rst
- docs/users_guide/exts/arrows.rst
- docs/users_guide/exts/data_kinds.rst
- docs/users_guide/exts/derive_any_class.rst
- docs/users_guide/exts/deriving_extra.rst
- docs/users_guide/exts/deriving_inferred.rst
- docs/users_guide/exts/deriving_strategies.rst
- docs/users_guide/exts/explicit_namespaces.rst
- docs/users_guide/exts/gadt.rst
- docs/users_guide/exts/gadt_syntax.rst
- docs/users_guide/exts/generics.rst
- docs/users_guide/exts/overloaded_labels.rst
- docs/users_guide/exts/overloaded_strings.rst
- docs/users_guide/exts/pattern_synonyms.rst
- docs/users_guide/exts/poly_kinds.rst
- docs/users_guide/exts/primitives.rst
- docs/users_guide/exts/rank_polymorphism.rst
- docs/users_guide/exts/rebindable_syntax.rst
- docs/users_guide/exts/required_type_arguments.rst
- docs/users_guide/exts/scoped_type_variables.rst
- docs/users_guide/exts/standalone_deriving.rst
- docs/users_guide/exts/template_haskell.rst
- docs/users_guide/exts/tuple_sections.rst
- docs/users_guide/exts/type_data.rst
- docs/users_guide/exts/type_defaulting.rst
- docs/users_guide/exts/type_families.rst
- docs/users_guide/ghci.rst
- docs/users_guide/gone_wrong.rst
- docs/users_guide/hints.rst
- docs/users_guide/javascript.rst
- docs/users_guide/phases.rst
- docs/users_guide/profiling.rst
- docs/users_guide/separate_compilation.rst
- docs/users_guide/using-optimisation.rst
- docs/users_guide/using.rst
- docs/users_guide/wasm.rst
- docs/users_guide/win32-dlls.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/bindist/config.mk.in
- hadrian/src/Builder.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules/Generate.hs
- hadrian/src/Rules/Gmp.hs
- hadrian/src/Rules/Libffi.hs
- hadrian/src/Rules/ToolArgs.hs
- hadrian/src/Settings.hs
- hadrian/src/Settings/Builders/Cabal.hs
- hadrian/src/Settings/Builders/Common.hs
- hadrian/src/Settings/Builders/DeriveConstants.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Builders/Hsc2Hs.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- hadrian/src/Settings/Warnings.hs
- hadrian/stack.yaml
- hadrian/stack.yaml.lock
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NonEmpty.hs
- + libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/Base.hs
- libraries/base/src/GHC/Exts.hs
- libraries/base/src/GHC/Num.hs
- + libraries/base/src/System/IO/OS.hs
- libraries/base/tests/all.T
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-boot/GHC/Unit/Database.hs
- libraries/ghc-boot/Setup.hs
- libraries/ghc-boot/ghc-boot.cabal.in
- libraries/ghc-experimental/CHANGELOG.md
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- + libraries/ghc-internal/cbits/RtsIface.c
- libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- + libraries/ghc-internal/include/RtsIfaceSymbols.h
- libraries/ghc-internal/src/GHC/Internal/Data/OldList.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/RTS/Flags.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc
- 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/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Quote.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- + libraries/ghc-internal/tests/backtraces/T26507.hs
- + libraries/ghc-internal/tests/backtraces/T26507.stderr
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/all.T
- libraries/ghc-prim/changelog.md
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ObjLink.hs
- libraries/ghci/GHCi/Run.hs
- libraries/os-string
- + libraries/template-haskell-lift
- + libraries/template-haskell-quasiquoter
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- libraries/unix
- libraries/xhtml
- m4/fp_check_pthreads.m4
- m4/fp_cmm_cpp_cmd_with_args.m4
- − m4/fp_set_cflags_c99.m4
- m4/fptools_alex.m4
- m4/fptools_happy.m4
- rts/Apply.cmm
- + rts/BuiltinClosures.c
- + rts/BuiltinClosures.h
- rts/CloneStack.h
- rts/Compact.cmm
- rts/ContinuationOps.cmm
- rts/Exception.cmm
- rts/ExecPage.c
- rts/Interpreter.c
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/Printer.c
- rts/ProfHeap.c
- rts/RetainerSet.c
- rts/RtsAPI.c
- rts/RtsFlags.c
- rts/RtsStartup.c
- rts/RtsSymbols.c
- + rts/RtsToHsIface.c
- rts/StgMiscClosures.cmm
- rts/StgStdThunks.cmm
- rts/ThreadPaused.c
- rts/configure.ac
- rts/eventlog/EventLog.c
- − rts/external-symbols.list.in
- rts/gen_event_types.py
- rts/include/Rts.h
- rts/include/RtsAPI.h
- rts/include/Stg.h
- rts/include/rts/Bytecodes.h
- rts/include/rts/Constants.h
- rts/include/rts/Flags.h
- + rts/include/rts/RtsToHsIface.h
- rts/include/rts/Types.h
- rts/include/rts/storage/Block.h
- rts/include/stg/MiscClosures.h
- rts/include/stg/Prim.h
- rts/linker/Elf.c
- rts/linker/LoadArchive.c
- rts/linker/PEi386.c
- rts/posix/OSMem.c
- rts/posix/Signals.c
- libraries/ghc-internal/cbits/atomic.c → rts/prim/atomic.c
- libraries/ghc-internal/cbits/bitrev.c → rts/prim/bitrev.c
- libraries/ghc-internal/cbits/bswap.c → rts/prim/bswap.c
- libraries/ghc-internal/cbits/clz.c → rts/prim/clz.c
- libraries/ghc-internal/cbits/ctz.c → rts/prim/ctz.c
- libraries/ghc-internal/cbits/int64x2minmax.c → rts/prim/int64x2minmax.c
- libraries/ghc-internal/cbits/longlong.c → rts/prim/longlong.c
- libraries/ghc-internal/cbits/mulIntMayOflo.c → rts/prim/mulIntMayOflo.c
- libraries/ghc-internal/cbits/pdep.c → rts/prim/pdep.c
- libraries/ghc-internal/cbits/pext.c → rts/prim/pext.c
- libraries/ghc-internal/cbits/popcnt.c → rts/prim/popcnt.c
- libraries/ghc-internal/cbits/vectorQuotRem.c → rts/prim/vectorQuotRem.c
- libraries/ghc-internal/cbits/word2float.c → rts/prim/word2float.c
- rts/rts.buildinfo.in
- rts/rts.cabal
- rts/sm/NonMoving.c
- rts/sm/NonMovingMark.c
- rts/sm/Scav.c
- rts/wasm/JSFFI.c
- rts/wasm/scheduler.cmm
- rts/win32/libHSghc-internal.def
- testsuite/config/ghc
- testsuite/driver/cpu_features.py
- testsuite/driver/runtests.py
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/mk/boilerplate.mk
- testsuite/tests/backpack/should_fail/T19244a.stderr
- + testsuite/tests/bytecode/T23973.hs
- + testsuite/tests/bytecode/T23973.script
- + testsuite/tests/bytecode/T23973.stdout
- testsuite/tests/bytecode/T24634/T24634a.stdout
- testsuite/tests/bytecode/T24634/T24634b.stdout
- + testsuite/tests/bytecode/T26565.hs
- + testsuite/tests/bytecode/T26565.script
- + testsuite/tests/bytecode/T26565.stdout
- + 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/cmm/opt/T25664.hs
- + testsuite/tests/cmm/opt/T25664.stdout
- testsuite/tests/cmm/opt/all.T
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.asm
- + testsuite/tests/codeGen/should_gen_asm/mavx-should-enable-popcnt.hs
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.asm
- + testsuite/tests/codeGen/should_gen_asm/msse-option-order.hs
- + testsuite/tests/codeGen/should_run/T24016.hs
- + testsuite/tests/codeGen/should_run/T24016.stdout
- + testsuite/tests/codeGen/should_run/T26537.hs
- + testsuite/tests/codeGen/should_run/T26537.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/concurrent/prog001/all.T
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout
- testsuite/tests/cpranal/should_compile/T18174.stderr
- + testsuite/tests/cross/should_run/T26449.hs
- + testsuite/tests/cross/should_run/all.T
- testsuite/tests/default/default-fail05.stderr
- testsuite/tests/dependent/should_fail/T11334b.stderr
- testsuite/tests/dependent/should_fail/T13135_simple.stderr
- testsuite/tests/deriving/should_fail/T3621.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/driver/Makefile
- testsuite/tests/driver/T11429c.stderr
- + testsuite/tests/driver/T20696/T20696.stderr-ext-interp
- testsuite/tests/driver/T21682.stderr
- + testsuite/tests/driver/T24120.hs
- + testsuite/tests/driver/T24731.hs
- + testsuite/tests/driver/T26551.hs
- + testsuite/tests/driver/T26551.stderr
- testsuite/tests/driver/T5313.hs
- testsuite/tests/driver/all.T
- + testsuite/tests/driver/bytecode-object/A.hs
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.c
- + testsuite/tests/driver/bytecode-object/BytecodeForeign.hs
- + testsuite/tests/driver/bytecode-object/BytecodeMain.hs
- + testsuite/tests/driver/bytecode-object/BytecodeTest.hs
- + testsuite/tests/driver/bytecode-object/Makefile
- + testsuite/tests/driver/bytecode-object/all.T
- + testsuite/tests/driver/bytecode-object/bytecode_object12.stderr
- + testsuite/tests/driver/bytecode-object/bytecode_object13.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object14.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object15.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object16.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object17.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object18.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object19.script
- + 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/bytecode-object/bytecode_object25.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object4.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object5.stdout
- + testsuite/tests/driver/bytecode-object/bytecode_object6.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405.stdout
- testsuite/tests/driver/fat-iface/T22405/T22405b.stdout
- testsuite/tests/driver/fat-iface/fat011.stderr
- + 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/generics/T10604/T10604_deriving.stderr
- + testsuite/tests/ghc-api-browser/README.md
- + testsuite/tests/ghc-api-browser/all.T
- + testsuite/tests/ghc-api-browser/index.html
- + testsuite/tests/ghc-api-browser/playground001.hs
- + testsuite/tests/ghc-api-browser/playground001.js
- + testsuite/tests/ghc-api-browser/playground001.sh
- + testsuite/tests/ghc-api-browser/playground001.stdout
- testsuite/tests/ghc-api/T10052/T10052.hs
- testsuite/tests/ghc-api/T10942.hs
- + testsuite/tests/ghc-api/T26264.hs
- + testsuite/tests/ghc-api/T26264.stdout
- testsuite/tests/ghc-api/T8639_api.hs
- testsuite/tests/ghc-api/all.T
- testsuite/tests/ghc-api/annotations-literals/literals.hs
- testsuite/tests/ghc-api/apirecomp001/myghc.hs
- testsuite/tests/ghc-e/should_fail/T9930fail.stderr
- testsuite/tests/ghc-e/should_fail/all.T
- testsuite/tests/ghci.debugger/scripts/print012.stdout
- testsuite/tests/ghci/linking/dyn/T3372.hs
- testsuite/tests/ghci/scripts/T10321.stdout
- testsuite/tests/ghci/scripts/T24459.stdout
- testsuite/tests/ghci/scripts/T7730.stdout
- testsuite/tests/ghci/scripts/T8959b.stderr
- testsuite/tests/ghci/scripts/ghci051.stderr
- testsuite/tests/ghci/scripts/ghci065.stdout
- testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T
- testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
- testsuite/tests/ghci/should_run/UnliftedDataTypeInterp/unlifteddatatypeinterp.T
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.hs
- testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr
- testsuite/tests/indexed-types/should_compile/T12538.stderr
- testsuite/tests/indexed-types/should_fail/T14369.stderr
- testsuite/tests/indexed-types/should_fail/T14887.stderr
- testsuite/tests/indexed-types/should_fail/T1897b.stderr
- testsuite/tests/indexed-types/should_fail/T21092.hs
- − testsuite/tests/indexed-types/should_fail/T21092.stderr
- testsuite/tests/indexed-types/should_fail/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
- testsuite/tests/interface-stability/ghc-prim-exports.stdout
- testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32
- + testsuite/tests/linear/should_compile/LinearEtaExpansions.hs
- testsuite/tests/linear/should_compile/all.T
- testsuite/tests/linear/should_fail/T19361.stderr
- testsuite/tests/linear/should_fail/TypeClass.hs
- testsuite/tests/linear/should_fail/TypeClass.stderr
- testsuite/tests/linear/should_run/LinearGhci.stdout
- + testsuite/tests/linear/should_run/T26311.hs
- + testsuite/tests/linear/should_run/T26311.stdout
- testsuite/tests/linear/should_run/all.T
- testsuite/tests/linters/all.T
- testsuite/tests/linters/notes.stdout
- testsuite/tests/llvm/should_run/all.T
- + 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/module/mod4.stderr
- testsuite/tests/numeric/should_compile/T16402.stderr-ws-64
- testsuite/tests/overloadedrecflds/should_compile/BootFldReexport.stderr
- testsuite/tests/overloadedrecflds/should_fail/T16745.stderr
- testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480.stderr
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux1.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480_aux2.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.hs
- + testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr
- testsuite/tests/overloadedrecflds/should_fail/all.T
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
- testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
- testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.hs
- testsuite/tests/parser/should_fail/RecordDotSyntaxFail8.stderr
- + testsuite/tests/parser/should_fail/T12488c.hs
- + testsuite/tests/parser/should_fail/T12488c.stderr
- + testsuite/tests/parser/should_fail/T12488d.hs
- + testsuite/tests/parser/should_fail/T12488d.stderr
- testsuite/tests/parser/should_fail/T20654a.stderr
- testsuite/tests/parser/should_fail/all.T
- testsuite/tests/partial-sigs/should_fail/T14584a.stderr
- + testsuite/tests/patsyn/should_compile/T26465b.hs
- + testsuite/tests/patsyn/should_compile/T26465c.hs
- + testsuite/tests/patsyn/should_compile/T26465d.hs
- + testsuite/tests/patsyn/should_compile/T26465d.stderr
- testsuite/tests/patsyn/should_compile/all.T
- + testsuite/tests/patsyn/should_fail/T26465.hs
- + testsuite/tests/patsyn/should_fail/T26465.stderr
- testsuite/tests/patsyn/should_fail/all.T
- testsuite/tests/perf/compiler/Makefile
- + testsuite/tests/perf/compiler/MultiLayerModulesDefsGhciWithBytecodeFiles.script
- + testsuite/tests/perf/compiler/T26425.hs
- testsuite/tests/perf/compiler/all.T
- testsuite/tests/perf/should_run/T3586.hs
- testsuite/tests/perf/should_run/UniqLoop.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/pmcheck/should_compile/T26400.hs
- + testsuite/tests/pmcheck/should_compile/T26400.stderr
- + testsuite/tests/pmcheck/should_compile/T26400b.hs
- testsuite/tests/pmcheck/should_compile/all.T
- testsuite/tests/pmcheck/should_compile/pmcOrPats.stderr
- testsuite/tests/polykinds/T6068.stdout
- − testsuite/tests/process/process010.stdout-i386-unknown-solaris2
- testsuite/tests/quantified-constraints/T15359.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
- + testsuite/tests/rename/should_compile/T12488b.hs
- + testsuite/tests/rename/should_compile/T12488f.hs
- + 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/T12488a.hs
- + testsuite/tests/rename/should_fail/T12488a.stderr
- + testsuite/tests/rename/should_fail/T12488a_foo.hs
- + testsuite/tests/rename/should_fail/T12488a_foo.stderr
- + testsuite/tests/rename/should_fail/T12488e.hs
- + testsuite/tests/rename/should_fail/T12488e.stderr
- + testsuite/tests/rename/should_fail/T12488g.hs
- + testsuite/tests/rename/should_fail/T12488g.stderr
- testsuite/tests/rename/should_fail/T19843h.stderr
- testsuite/tests/rename/should_fail/T25899e2.stderr
- + 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/rename/should_fail/rnfail055.stderr
- testsuite/tests/rep-poly/RepPolyCase1.stderr
- − testsuite/tests/rep-poly/RepPolyCase2.stderr
- testsuite/tests/rep-poly/RepPolyNPlusK.stderr
- testsuite/tests/rep-poly/RepPolyRightSection.stderr
- testsuite/tests/rep-poly/RepPolyRule3.stderr
- testsuite/tests/rep-poly/RepPolyTuple4.stderr
- testsuite/tests/rep-poly/T13233.stderr
- − testsuite/tests/rep-poly/T17021.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T20363b.stderr
- − testsuite/tests/rep-poly/T21650_a.stderr
- − testsuite/tests/rep-poly/T21650_b.stderr
- testsuite/tests/rep-poly/T23903.stderr
- + testsuite/tests/rep-poly/T26072.hs
- + testsuite/tests/rep-poly/T26072b.hs
- + testsuite/tests/rep-poly/T26528.hs
- testsuite/tests/rep-poly/UnliftedNewtypesLevityBinder.stderr
- testsuite/tests/rep-poly/all.T
- testsuite/tests/roles/should_compile/Roles13.stderr
- testsuite/tests/rts/KeepCafsBase.hs
- testsuite/tests/rts/T22859.hs
- testsuite/tests/rts/all.T
- + testsuite/tests/rts/ipe/distinct-tables/Main.hs
- + testsuite/tests/rts/ipe/distinct-tables/Makefile
- + testsuite/tests/rts/ipe/distinct-tables/X.hs
- + testsuite/tests/rts/ipe/distinct-tables/all.T
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables01.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables02.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables03.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables04.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables05.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables06.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables07.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables08.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables09.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables10.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables11.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables12.stdout
- + testsuite/tests/rts/ipe/distinct-tables/distinct_tables13.stdout
- − testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32
- − testsuite/tests/rts/linker/T11223/T11223_simple_duplicate_lib.stderr-ws-32-mingw32
- testsuite/tests/rts/linker/T2615.hs
- − testsuite/tests/rts/outofmem.stderr-i386-apple-darwin
- − testsuite/tests/rts/outofmem.stderr-i386-unknown-mingw32
- − testsuite/tests/rts/outofmem.stderr-powerpc-apple-darwin
- testsuite/tests/saks/should_compile/saks023.stdout
- testsuite/tests/saks/should_compile/saks034.stdout
- testsuite/tests/saks/should_compile/saks035.stdout
- testsuite/tests/showIface/Makefile
- + testsuite/tests/showIface/T26246a.hs
- + testsuite/tests/showIface/T26246a.stdout
- testsuite/tests/showIface/all.T
- + testsuite/tests/simd/should_run/T26410_ffi.hs
- + testsuite/tests/simd/should_run/T26410_ffi.stdout
- + testsuite/tests/simd/should_run/T26410_ffi_c.c
- + testsuite/tests/simd/should_run/T26410_prim.hs
- + testsuite/tests/simd/should_run/T26410_prim.stdout
- + testsuite/tests/simd/should_run/T26542.hs
- + testsuite/tests/simd/should_run/T26542.stdout
- + testsuite/tests/simd/should_run/T26550.hs
- + testsuite/tests/simd/should_run/T26550.stdout
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simd/should_run/simd015.hs
- + testsuite/tests/simd/should_run/simd015.stdout
- + testsuite/tests/simd/should_run/simd016.hs
- + testsuite/tests/simd/should_run/simd016.stdout
- + testsuite/tests/simd/should_run/simd017.hs
- + testsuite/tests/simd/should_run/simd017.stdout
- testsuite/tests/simplCore/should_compile/OpaqueNoCastWW.stderr
- testsuite/tests/simplCore/should_compile/T17673.stderr
- testsuite/tests/simplCore/should_compile/T18078.stderr
- testsuite/tests/simplCore/should_compile/T18995.stderr
- testsuite/tests/simplCore/should_compile/T19890.stderr
- testsuite/tests/simplCore/should_compile/T21948.stderr
- testsuite/tests/simplCore/should_compile/T21960.stderr
- testsuite/tests/simplCore/should_compile/T24808.stderr
- − testsuite/tests/simplCore/should_compile/T25713.stderr
- + testsuite/tests/simplCore/should_compile/T26349.hs
- + testsuite/tests/simplCore/should_compile/T26349.stderr
- + testsuite/tests/simplCore/should_compile/T26588.hs
- + testsuite/tests/simplCore/should_compile/T26589.hs
- testsuite/tests/simplCore/should_compile/T4201.stdout
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/rule2.stderr
- testsuite/tests/simplStg/should_compile/T22840.stderr
- + testsuite/tests/splice-imports/SI07.stderr-ext-interp
- + testsuite/tests/th/T26099.hs
- + testsuite/tests/th/T26099.stderr
- + testsuite/tests/th/T26568.hs
- + testsuite/tests/th/T26568.stderr
- testsuite/tests/th/T8761.stderr
- testsuite/tests/th/all.T
- testsuite/tests/typecheck/T16127/T16127.stderr
- testsuite/tests/typecheck/no_skolem_info/T13499.stderr
- testsuite/tests/typecheck/no_skolem_info/T20232.stderr
- testsuite/tests/typecheck/should_compile/T13651.hs
- − testsuite/tests/typecheck/should_compile/T13651.stderr
- + testsuite/tests/typecheck/should_compile/T14745.hs
- + testsuite/tests/typecheck/should_compile/T17705.hs
- testsuite/tests/typecheck/should_compile/T22560d.stdout
- + testsuite/tests/typecheck/should_compile/T26451.hs
- + testsuite/tests/typecheck/should_compile/T26457.hs
- + testsuite/tests/typecheck/should_compile/T26582.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_compile/hole_constraints_nested.stderr
- testsuite/tests/typecheck/should_compile/tc126.hs
- testsuite/tests/typecheck/should_fail/AmbigFDs.hs
- − testsuite/tests/typecheck/should_fail/AmbigFDs.stderr
- testsuite/tests/typecheck/should_fail/FD3.stderr
- testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
- testsuite/tests/typecheck/should_fail/T11672.stderr
- testsuite/tests/typecheck/should_fail/T12373.stderr
- testsuite/tests/typecheck/should_fail/T13506.stderr
- testsuite/tests/typecheck/should_fail/T15629.stderr
- testsuite/tests/typecheck/should_fail/T15807.stderr
- testsuite/tests/typecheck/should_fail/T15883e.stderr
- testsuite/tests/typecheck/should_fail/T16074.stderr
- testsuite/tests/typecheck/should_fail/T16512a.stderr
- testsuite/tests/typecheck/should_fail/T18357a.stderr
- testsuite/tests/typecheck/should_fail/T18851b.hs
- − testsuite/tests/typecheck/should_fail/T18851b.stderr
- testsuite/tests/typecheck/should_fail/T18851c.hs
- − testsuite/tests/typecheck/should_fail/T18851c.stderr
- testsuite/tests/typecheck/should_fail/T19415.stderr
- testsuite/tests/typecheck/should_fail/T19415b.stderr
- testsuite/tests/typecheck/should_fail/T19627.stderr
- testsuite/tests/typecheck/should_fail/T20241b.stderr
- testsuite/tests/typecheck/should_fail/T21530a.stderr
- testsuite/tests/typecheck/should_fail/T22684.stderr
- + testsuite/tests/typecheck/should_fail/T23162a.hs
- + testsuite/tests/typecheck/should_fail/T23162a.stderr
- testsuite/tests/typecheck/should_fail/T2414.stderr
- testsuite/tests/typecheck/should_fail/T24279.hs
- − testsuite/tests/typecheck/should_fail/T24279.stderr
- testsuite/tests/typecheck/should_fail/T25325.stderr
- testsuite/tests/typecheck/should_fail/T2534.stderr
- testsuite/tests/typecheck/should_fail/T5246.stderr
- testsuite/tests/typecheck/should_fail/T5978.stderr
- testsuite/tests/typecheck/should_fail/T7264.stderr
- testsuite/tests/typecheck/should_fail/T7368a.stderr
- testsuite/tests/typecheck/should_fail/T7696.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/T9612.stderr
- testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr
- testsuite/tests/typecheck/should_fail/UnliftedNewtypesFamilyKindFail2.stderr
- testsuite/tests/typecheck/should_fail/VisFlag1.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/should_fail/tcfail122.stderr
- testsuite/tests/typecheck/should_fail/tcfail143.stderr
- testsuite/tests/unboxedsums/UbxSumUnpackedSize.hs
- + testsuite/tests/warnings/should_compile/DodgyExports02.hs
- + testsuite/tests/warnings/should_compile/DodgyExports02.stderr
- + testsuite/tests/warnings/should_compile/DodgyExports03.hs
- + testsuite/tests/warnings/should_compile/DodgyExports03.stderr
- + testsuite/tests/warnings/should_compile/DuplicateModExport.hs
- + testsuite/tests/warnings/should_compile/DuplicateModExport.stderr
- + testsuite/tests/warnings/should_compile/EmptyModExport.hs
- + testsuite/tests/warnings/should_compile/EmptyModExport.stderr
- + 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/Parsers.hs
- utils/check-exact/Preprocess.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/deriveConstants/Main.hs
- utils/genprimopcode/genprimopcode.cabal
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/ghc-toolchain.cabal
- utils/ghc-toolchain/src/GHC/Toolchain/CheckArm.hs
- + utils/ghc-toolchain/src/GHC/Toolchain/CheckPower.hs
- utils/ghc-toolchain/src/GHC/Toolchain/ParseTriple.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/MergeObjs.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/LaTeX.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/Convert.hs
- utils/haddock/haddock-api/src/Haddock/Doc.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
- utils/haddock/haddock-api/src/Haddock/Utils.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/haddock/haddock-test/src/Test/Haddock.hs
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/Bug26.html
- + utils/haddock/html-test/ref/Bug26246.html
- utils/haddock/html-test/ref/Bug298.html
- utils/haddock/html-test/ref/Bug458.html
- utils/haddock/html-test/ref/Bug85.html
- utils/haddock/html-test/ref/Bug923.html
- utils/haddock/html-test/ref/BundledPatterns.html
- utils/haddock/html-test/ref/BundledPatterns2.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/GADTRecords.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/Nesting.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/PromotedTypes.html
- utils/haddock/html-test/ref/TitledPicture.html
- utils/haddock/html-test/ref/TypeOperators.html
- utils/haddock/html-test/ref/Unicode.html
- utils/haddock/html-test/ref/Unicode2.html
- + utils/haddock/html-test/src/Bug26246.hs
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/hypsrc-test/ref/src/Classes.html
- utils/haddock/hypsrc-test/ref/src/Quasiquoter.html
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
- utils/hpc
- utils/hsc2hs
- utils/iserv/iserv.cabal.in
- utils/jsffi/dyld.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b6ef1bfd4734cd0cc50974eb5b040d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b6ef1bfd4734cd0cc50974eb5b040d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Quantify arg before mult in function arrows
by Marge Bot (＠marge-bot) 11 Dec '25
by Marge Bot (＠marge-bot) 11 Dec '25
11 Dec '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ac0815d5 by sheaf at 2025-12-10T23:39:57-05:00
Quantify arg before mult in function arrows
As noted in #23764, we expect quantification order to be left-to-right,
so that in a type such as
a %m -> b
the inferred quantification order should be [a, m, b] and not [m, a, b].
This was addressed in commit d31fbf6c, but that commit failed to update
some other functions such as GHC.Core.TyCo.FVs.tyCoFVsOfType.
This affects Haddock, as whether we print an explicit forall or not
depends on whether the inferred quantification order matches the actual
quantification order.
- - - - -
2caf796e by sheaf at 2025-12-10T23:39:57-05:00
Haddock: improvements to ty-var quantification
This commit makes several improvements to how Haddock deals with the
quantification of type variables:
1. In pattern synonyms, Haddock used to jumble up universal and
existential quantification. That is now fixed, fixing #26252.
Tested in the 'PatternSyns2' haddock-html test.
2. The logic for computing whether to use an explicit kind annotation
for a type variable quantified in a forall was not even wrong.
This commit improves the heuristic, but it will always remain an
imperfect heuristic (lest we actually run kind inference again).
In the future (#26271), we hope to avoid reliance on this heuristic.
- - - - -
b14bdd59 by Teo Camarasu at 2025-12-10T23:40:38-05:00
Add explicit export list to GHC.Num
Let's make clear what this module exports to allow us to easily deprecate and remove some of these in the future. Resolves https://gitlab.haskell.org/ghc/ghc/-/issues/26625
- - - - -
0fce9d8f by Cheng Shao at 2025-12-11T13:23:54-05:00
compiler: remove unused CPP code in foreign stub
This patch removes unused CPP code in the generated foreign stub:
- `#define IN_STG_CODE 0` is not needed, since `Rts.h` already
includes this definition
- The `if defined(__cplusplus)` code paths are not needed in the `.c`
file, since we don't generate C++ stubs and don't include C++
headers in our stubs. But it still needs to be present in the `.h`
header since it might be later included into C++ source files.
- - - - -
2f18fba7 by Cheng Shao at 2025-12-11T13:23:55-05: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.
- - - - -
20 changed files:
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- configure.ac
- libraries/base/src/GHC/Num.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- utils/haddock/haddock-api/src/Haddock/Convert.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/html-test/ref/Bug1050.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/PatternSyns.html
- + utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/TypeOperators.html
- + utils/haddock/html-test/src/PatternSyns2.hs
- utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
Changes:
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -635,7 +635,9 @@ tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_v
-- See Note [Free vars and synonyms]
tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc
tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc
-tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc
+tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc =
+ -- As per #23764, if we have 'a %m -> b', quantification order should be [a,m,b] not [m,a,b].
+ (tyCoFVsOfType arg `unionFV` tyCoFVsOfType w `unionFV` tyCoFVsOfType res) f bound_vars acc
tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc
tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc
tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc
@@ -958,7 +960,9 @@ invisibleVarsOfType = go
= go ty'
go (TyVarTy v) = go (tyVarKind v)
go (AppTy f a) = go f `unionFV` go a
- go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2
+ go (FunTy _ w ty1 ty2) =
+ -- As per #23764, order is: arg, mult, res.
+ go ty1 `unionFV` go w `unionFV` go ty2
go (TyConApp tc tys) = tyCoFVsOfTypes invisibles `unionFV`
invisibleVarsOfTypes visibles
where (invisibles, visibles) = partitionInvisibleTypes tc tys
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -1984,7 +1984,9 @@ foldTyCo (TyCoFolder { tcf_view = view
go_ty _ (LitTy {}) = mempty
go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co
go_ty env (CoercionTy co) = go_co env co
- go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res
+ go_ty env (FunTy _ w arg res) =
+ -- As per #23764, ordering is [arg, w, res].
+ go_ty env arg `mappend` go_ty env w `mappend` go_ty env res
go_ty env (TyConApp _ tys) = go_tys env tys
go_ty env (ForAllTy (Bndr tv vis) inner)
= let !env' = tycobinder env tv vis -- Avoid building a thunk here
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -329,15 +329,8 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_c_file_exists
<- outputForeignStubs_help stub_c stub_c_output_w
- ("#define IN_STG_CODE 0\n" ++
- "#include <Rts.h>\n" ++
- rts_includes ++
- ffi_includes ++
- cplusplus_hdr)
- cplusplus_ftr
- -- We're adding the default hc_header to the stub file, but this
- -- isn't really HC code, so we need to define IN_STG_CODE==0 to
- -- avoid the register variables etc. being enabled.
+ (rts_includes ++
+ ffi_includes) ""
return (stub_h_file_exists, if stub_c_file_exists
then Just stub_c
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1432,7 +1432,7 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
-- Uses accumulating-parameter style
go dv (AppTy t1 t2) = foldlM go dv [t1, t2]
go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys
- go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res]
+ go dv (FunTy _ w arg res) = foldlM go dv [arg, w, res]
go dv (LitTy {}) = return dv
go dv (CastTy ty co) = do { dv1 <- go dv ty
; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co }
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -1009,8 +1009,8 @@ tcTyFamInstsAndVisX = go
go _ (LitTy {}) = []
go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr)
++ go is_invis_arg ty
- go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg w
- ++ go is_invis_arg ty1
+ go is_invis_arg (FunTy _ w ty1 ty2) = go is_invis_arg ty1
+ ++ go is_invis_arg w
++ go is_invis_arg ty2
go is_invis_arg ty@(AppTy _ _) =
let (ty_head, ty_args) = splitAppTys ty
=====================================
configure.ac
=====================================
@@ -526,7 +526,7 @@ AC_SUBST(InstallNameToolCmd)
# versions of LLVM simultaneously, but that stopped working around
# 3.5/3.6 release of LLVM.
LlvmMinVersion=13 # inclusive
-LlvmMaxVersion=21 # not inclusive
+LlvmMaxVersion=22 # not inclusive
AC_SUBST([LlvmMinVersion])
AC_SUBST([LlvmMaxVersion])
=====================================
libraries/base/src/GHC/Num.hs
=====================================
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
@@ -16,11 +17,190 @@ module GHC.Num
( Num(..)
, subtract
, quotRemInteger
- , module GHC.Num.Integer
- , module GHC.Num.Natural
+ , integerFromNatural
+ , integerToNaturalClamp
+ , integerToNaturalThrow
+ , integerToNatural
+ , integerToWord#
+ , integerToInt#
+ , integerToWord64#
+ , integerToInt64#
+ , integerAdd
+ , integerMul
+ , integerSub
+ , integerNegate
+ , integerAbs
+ , integerPopCount#
+ , integerQuot
+ , integerRem
+ , integerDiv
+ , integerMod
+ , integerDivMod#
+ , integerQuotRem#
+ , integerEncodeFloat#
+ , integerEncodeDouble#
+ , integerGcd
+ , integerLcm
+ , integerAnd
+ , integerOr
+ , integerXor
+ , integerComplement
+ , integerBit#
+ , integerTestBit#
+ , integerShiftL#
+ , integerShiftR#
+ , integerFromWord#
+ , integerFromWord64#
+ , integerFromInt64#
+ , Integer(..)
+ , integerBit
+ , integerCheck
+ , integerCheck#
+ , integerCompare
+ , integerDecodeDouble#
+ , integerDivMod
+ , integerEncodeDouble
+ , integerEq
+ , integerEq#
+ , integerFromAddr
+ , integerFromAddr#
+ , integerFromBigNat#
+ , integerFromBigNatNeg#
+ , integerFromBigNatSign#
+ , integerFromByteArray
+ , integerFromByteArray#
+ , integerFromInt
+ , integerFromInt#
+ , integerFromWord
+ , integerFromWordList
+ , integerFromWordNeg#
+ , integerFromWordSign#
+ , integerGcde
+ , integerGcde#
+ , integerGe
+ , integerGe#
+ , integerGt
+ , integerGt#
+ , integerIsNegative
+ , integerIsNegative#
+ , integerIsOne
+ , integerIsPowerOf2#
+ , integerIsZero
+ , integerLe
+ , integerLe#
+ , integerLog2
+ , integerLog2#
+ , integerLogBase
+ , integerLogBase#
+ , integerLogBaseWord
+ , integerLogBaseWord#
+ , integerLt
+ , integerLt#
+ , integerNe
+ , integerNe#
+ , integerOne
+ , integerPowMod#
+ , integerQuotRem
+ , integerRecipMod#
+ , integerShiftL
+ , integerShiftR
+ , integerSignum
+ , integerSignum#
+ , integerSizeInBase#
+ , integerSqr
+ , integerTestBit
+ , integerToAddr
+ , integerToAddr#
+ , integerToBigNatClamp#
+ , integerToBigNatSign#
+ , integerToInt
+ , integerToMutableByteArray
+ , integerToMutableByteArray#
+ , integerToWord
+ , integerZero
+ , naturalToWord#
+ , naturalPopCount#
+ , naturalShiftR#
+ , naturalShiftL#
+ , naturalAdd
+ , naturalSub
+ , naturalSubThrow
+ , naturalSubUnsafe
+ , naturalMul
+ , naturalQuotRem#
+ , naturalQuot
+ , naturalRem
+ , naturalAnd
+ , naturalAndNot
+ , naturalOr
+ , naturalXor
+ , naturalTestBit#
+ , naturalBit#
+ , naturalGcd
+ , naturalLcm
+ , naturalLog2#
+ , naturalLogBaseWord#
+ , naturalLogBase#
+ , naturalPowMod
+ , naturalSizeInBase#
+ , Natural(..)
+ , naturalBit
+ , naturalCheck
+ , naturalCheck#
+ , naturalClearBit
+ , naturalClearBit#
+ , naturalCompare
+ , naturalComplementBit
+ , naturalComplementBit#
+ , naturalEncodeDouble#
+ , naturalEncodeFloat#
+ , naturalEq
+ , naturalEq#
+ , naturalFromAddr
+ , naturalFromAddr#
+ , naturalFromBigNat#
+ , naturalFromByteArray#
+ , naturalFromWord
+ , naturalFromWord#
+ , naturalFromWord2#
+ , naturalFromWordList
+ , naturalGe
+ , naturalGe#
+ , naturalGt
+ , naturalGt#
+ , naturalIsOne
+ , naturalIsPowerOf2#
+ , naturalIsZero
+ , naturalLe
+ , naturalLe#
+ , naturalLog2
+ , naturalLogBase
+ , naturalLogBaseWord
+ , naturalLt
+ , naturalLt#
+ , naturalNe
+ , naturalNe#
+ , naturalNegate
+ , naturalOne
+ , naturalPopCount
+ , naturalQuotRem
+ , naturalSetBit
+ , naturalSetBit#
+ , naturalShiftL
+ , naturalShiftR
+ , naturalSignum
+ , naturalSqr
+ , naturalTestBit
+ , naturalToAddr
+ , naturalToAddr#
+ , naturalToBigNat#
+ , naturalToMutableByteArray#
+ , naturalToWord
+ , naturalToWordClamp
+ , naturalToWordClamp#
+ , naturalToWordMaybe#
+ , naturalZero
)
where
import GHC.Internal.Num
-import GHC.Num.Integer
-import GHC.Num.Natural
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -11397,7 +11397,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -8569,7 +8569,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -8351,7 +8351,7 @@ module GHC.Natural where
xorNatural :: Natural -> Natural -> Natural
module GHC.Num where
- -- Safety: None
+ -- Safety: Safe-Inferred
type Integer :: *
data Integer = IS GHC.Internal.Prim.Int# | IP GHC.Internal.Prim.ByteArray# | IN GHC.Internal.Prim.ByteArray#
type Natural :: *
=====================================
utils/haddock/haddock-api/src/Haddock/Convert.hs
=====================================
@@ -29,7 +29,7 @@ module Haddock.Convert
import Control.DeepSeq (force)
import Data.Either (lefts, partitionEithers, rights)
-import Data.Maybe (catMaybes, mapMaybe, maybeToList)
+import Data.Maybe (catMaybes, mapMaybe)
import GHC.Builtin.Names
( boxedRepDataConKey
, eqTyConKey
@@ -140,7 +140,7 @@ tyThingToLHsDecl prr t = case t of
hsq_explicit $
fdTyVars fd
, feqn_fixity = fdFixity fd
- , feqn_rhs = synifyType WithinType [] rhs
+ , feqn_rhs = synifyType WithinType emptyVarSet rhs
}
extractAtItem
@@ -179,7 +179,7 @@ tyThingToLHsDecl prr t = case t of
noLocA (MinimalSig (noAnn, NoSourceText) . noLocA $ classMinimalDef cl)
: [ noLocA tcdSig
| clsOp <- classOpItems cl
- , tcdSig <- synifyTcIdSig vs clsOp
+ , tcdSig <- synifyTcIdSig (mkVarSet vs) clsOp
]
, tcdMeths = [] -- ignore default method definitions, they don't affect signature
-- class associated-types are a subset of TyCon:
@@ -213,9 +213,9 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn
synifyAxBranch tc (CoAxBranch{cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs}) =
let name = synifyNameN tc
args_types_only = filterOutInvisibleTypes tc args
- typats = map (synifyType WithinType []) args_types_only
+ typats = map (synifyType WithinType emptyVarSet) args_types_only
annot_typats = zipWith3 annotHsType args_poly args_types_only typats
- hs_rhs = synifyType WithinType [] rhs
+ hs_rhs = synifyType WithinType emptyVarSet rhs
outer_bndrs = HsOuterImplicit{hso_ximplicit = map tyVarName tkvs}
in -- TODO: this must change eventually
FamEqn
@@ -344,7 +344,7 @@ synifyTyCon _prr coax tc
, tcdLName = synifyNameN tc
, tcdTyVars = synifyTyVars (tyConVisibleTyVars tc)
, tcdFixity = synifyFixity tc
- , tcdRhs = synifyType WithinType [] ty
+ , tcdRhs = synifyType WithinType emptyVarSet ty
}
-- (closed) newtype and data
| otherwise = do
@@ -578,8 +578,8 @@ synifyDataCon use_gadt_syntax dc =
linear_tys =
zipWith
( \(Scaled mult ty) (HsSrcBang st unp str) ->
- let tySyn = synifyType WithinType [] ty
- multSyn = synifyMultRec [] mult
+ let tySyn = synifyType WithinType emptyVarSet ty
+ multSyn = synifyMultRec emptyVarSet mult
in CDF (noAnn, st) unp str multSyn tySyn Nothing
)
arg_tys
@@ -620,7 +620,7 @@ synifyDataCon use_gadt_syntax dc =
, con_inner_bndrs = inner_bndrs
, con_mb_cxt = ctx
, con_g_args = hat
- , con_res_ty = synifyType WithinType [] res_ty
+ , con_res_ty = synifyType WithinType emptyVarSet res_ty
, con_doc = Nothing
}
else do
@@ -657,11 +657,11 @@ synifyIdSig
-> SynifyTypeState
-- ^ what to do with a 'forall'
-> [TyVar]
- -- ^ free variables in the type to convert
+ -- ^ type variables bound from an outer scope
-> Id
-- ^ the 'Id' from which to get the type signature
-> Sig GhcRn
-synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
+synifyIdSig prr s boundTvs i = TypeSig noAnn [n] (synifySigWcType s boundTvs t)
where
!n = force $ synifyNameN i
t = defaultType prr (varType i)
@@ -669,18 +669,18 @@ synifyIdSig prr s vs i = TypeSig noAnn [n] (synifySigWcType s vs t)
-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going
-- to contain the synified 'ClassOpSig' as well (when appropriate) a default
-- 'ClassOpSig'.
-synifyTcIdSig :: [TyVar] -> ClassOpItem -> [Sig GhcRn]
-synifyTcIdSig vs (i, dm) =
+synifyTcIdSig :: TyVarSet -> ClassOpItem -> [Sig GhcRn]
+synifyTcIdSig boundTvs (i, dm) =
[ClassOpSig noAnn False [synifyNameN i] (mainSig (varType i))]
++ [ ClassOpSig noAnn True [noLocA dn] (defSig dt)
| Just (dn, GenericDM dt) <- [dm]
]
where
- mainSig t = synifySigType DeleteTopLevelQuantification vs t
- defSig t = synifySigType ImplicitizeForAll vs t
+ mainSig t = synifySigType DeleteTopLevelQuantification boundTvs t
+ defSig t = synifySigType ImplicitizeForAll boundTvs t
synifyCtx :: [PredType] -> LHsContext GhcRn
-synifyCtx ts = noLocA (map (synifyType WithinType []) ts)
+synifyCtx ts = noLocA (map (synifyType WithinType emptyVarSet) ts)
synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn
synifyTyVars ktvs =
@@ -699,7 +699,7 @@ synifyTyVarBndr' :: VarSet -> VarBndr TyVar flag -> LHsTyVarBndr flag GhcRn
synifyTyVarBndr' no_kinds (Bndr tv spec) = synify_ty_var no_kinds spec tv
-- | Like 'synifyTyVarBndr', but accepts a set of variables for which to omit kind
--- signatures (even if they don't have the lifted type kind).
+-- signatures (even if they don't have kind 'Type').
synify_ty_var :: VarSet -> flag -> TyVar -> LHsTyVarBndr flag GhcRn
synify_ty_var no_kinds flag tv =
noLocA (HsTvb noAnn flag bndr_var bndr_kind)
@@ -726,7 +726,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig{})) = hs_ty
annotHsType True ty hs_ty
| not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty =
let ki = typeKind ty
- hs_ki = synifyType WithinType [] ki
+ hs_ki = synifyType WithinType emptyVarSet ki
in noLocA (HsKindSig noAnn hs_ty hs_ki)
annotHsType _ _ hs_ty = hs_ty
@@ -768,14 +768,15 @@ data SynifyTypeState
-- the defining class gets to quantify all its functions for free!
DeleteTopLevelQuantification
-synifySigType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigType GhcRn
+synifySigType :: SynifyTypeState -> TyVarSet -> Type -> LHsSigType GhcRn
-- The use of mkEmptySigType (which uses empty binders in OuterImplicit)
-- is a bit suspicious; what if the type has free variables?
-synifySigType s vs ty = mkEmptySigType (synifyType s vs ty)
+synifySigType s boundTvs ty = mkEmptySigType (synifyType s boundTvs ty)
synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn
-- Ditto (see synifySigType)
-synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s vs ty))
+synifySigWcType s vs ty =
+ mkEmptyWildCardBndrs (mkEmptySigType (rename (map getName vs) $ synifyType s (mkVarSet vs) ty))
synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn
-- Ditto (see synifySigType)
@@ -791,13 +792,13 @@ defaultType HideRuntimeRep = defaultRuntimeRepVars
synifyType
:: SynifyTypeState
-- ^ what to do with a 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the type to convert
-> LHsType GhcRn
synifyType _ _ (TyVarTy tv) = noLocA $ HsTyVar noAnn NotPromoted $ noLocA (noUserRdr $ getName tv)
-synifyType _ vs (TyConApp tc tys) =
+synifyType _ boundTvs (TyConApp tc tys) =
maybe_sig res_ty
where
res_ty :: LHsType GhcRn
@@ -819,24 +820,24 @@ synifyType _ vs (TyConApp tc tys) =
ConstraintTuple -> HsBoxedOrConstraintTuple
UnboxedTuple -> HsUnboxedTuple
)
- (map (synifyType WithinType vs) vis_tys)
+ (map (synifyType WithinType boundTvs) vis_tys)
| isUnboxedSumTyCon tc =
- noLocA $ HsSumTy noAnn (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsSumTy noAnn (map (synifyType WithinType boundTvs) vis_tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, dataConSourceArity dc == length vis_tys =
- noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType vs) vis_tys)
+ noLocA $ HsExplicitTupleTy noExtField IsPromoted (map (synifyType WithinType boundTvs) vis_tys)
-- ditto for lists
| getName tc == listTyConName
, [ty] <- vis_tys =
- noLocA $ HsListTy noAnn (synifyType WithinType vs ty)
+ noLocA $ HsListTy noAnn (synifyType WithinType boundTvs ty)
| tc == promotedNilDataCon
, [] <- vis_tys =
noLocA $ HsExplicitListTy noExtField IsPromoted []
| tc == promotedConsDataCon
, [ty1, ty2] <- vis_tys =
- let hTy = synifyType WithinType vs ty1
- in case synifyType WithinType vs ty2 of
+ let hTy = synifyType WithinType boundTvs ty1
+ in case synifyType WithinType boundTvs ty2 of
tTy
| L _ (HsExplicitListTy _ IsPromoted tTy') <- stripKindSig tTy ->
noLocA $ HsExplicitListTy noExtField IsPromoted (hTy : tTy')
@@ -846,7 +847,7 @@ synifyType _ vs (TyConApp tc tys) =
| tc `hasKey` ipClassKey
, [name, ty] <- tys
, Just x <- isStrLitTy name =
- noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType vs ty)
+ noLocA $ HsIParamTy noAnn (noLocA $ HsIPName x) (synifyType WithinType boundTvs ty)
-- and equalities
| tc `hasKey` eqTyConKey
, [ty1, ty2] <- tys =
@@ -854,9 +855,9 @@ synifyType _ vs (TyConApp tc tys) =
HsOpTy
noExtField
NotPromoted
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr eqTyConName)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
-- and infix type operators
| isSymOcc (nameOccName (getName tc))
, ty1 : ty2 : tys_rest <- vis_tys =
@@ -864,9 +865,9 @@ synifyType _ vs (TyConApp tc tys) =
( HsOpTy
noExtField
prom
- (synifyType WithinType vs ty1)
+ (synifyType WithinType boundTvs ty1)
(noLocA $ noUserRdr $ getName tc)
- (synifyType WithinType vs ty2)
+ (synifyType WithinType boundTvs ty2)
)
tys_rest
-- Most TyCons:
@@ -880,7 +881,7 @@ synifyType _ vs (TyConApp tc tys) =
foldl
(\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2)
(noLocA ty_app)
- ( map (synifyType WithinType vs) $
+ ( map (synifyType WithinType boundTvs) $
filterOut isCoercionTy ty_args
)
@@ -891,56 +892,57 @@ synifyType _ vs (TyConApp tc tys) =
maybe_sig ty'
| tyConAppNeedsKindSig False tc tys_len =
let full_kind = typeKind (mkTyConApp tc tys)
- full_kind' = synifyType WithinType vs full_kind
+ full_kind' = synifyType WithinType boundTvs full_kind
in noLocA $ HsKindSig noAnn ty' full_kind'
| otherwise = ty'
-synifyType _ vs ty@(AppTy{}) =
+synifyType _ boundTvs ty@(AppTy{}) =
let
(ty_head, ty_args) = splitAppTys ty
- ty_head' = synifyType WithinType vs ty_head
+ ty_head' = synifyType WithinType boundTvs ty_head
ty_args' =
- map (synifyType WithinType vs) $
+ map (synifyType WithinType boundTvs) $
filterOut isCoercionTy $
filterByList
(map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args)
ty_args
in
foldl (\t1 t2 -> noLocA $ HsAppTy noExtField t1 t2) ty_head' ty_args'
-synifyType s vs funty@(FunTy af w t1 t2)
- | isInvisibleFunArg af = synifySigmaType s vs funty
+synifyType s boundTvs funty@(FunTy af w t1 t2)
+ | isInvisibleFunArg af = synifySigmaType s boundTvs funty
| otherwise = noLocA $ HsFunTy noExtField w' s1 s2
where
- s1 = synifyType WithinType vs t1
- s2 = synifyType WithinType vs t2
- w' = synifyMultArrow vs w
-synifyType s vs forallty@(ForAllTy (Bndr _ argf) _ty) =
+ s1 = synifyType WithinType boundTvs t1
+ s2 = synifyType WithinType boundTvs t2
+ w' = synifyMultArrow boundTvs w
+synifyType s boundTvs forallty@(ForAllTy (Bndr _ argf) _ty) =
case argf of
- Required -> synifyVisForAllType vs forallty
- Invisible _ -> synifySigmaType s vs forallty
+ Required -> synifyVisForAllType boundTvs forallty
+ Invisible _ -> synifySigmaType s boundTvs forallty
synifyType _ _ (LitTy t) = noLocA $ HsTyLit noExtField $ synifyTyLit t
-synifyType s vs (CastTy t _) = synifyType s vs t
+synifyType s boundTvs (CastTy t _) = synifyType s boundTvs t
synifyType _ _ (CoercionTy{}) = error "synifyType:Coercion"
-- | Process a 'Type' which starts with a visible @forall@ into an 'HsType'
synifyVisForAllType
- :: [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifyVisForAllType vs ty =
+synifyVisForAllType boundTvs ty =
let (tvs, rho) = tcSplitForAllTysReqPreserveSynonyms ty
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) [rho]
+ tvs' = orderedFVs boundTvs [rho]
in noLocA $
HsForAllTy
{ hst_tele = mkHsForAllVisTele noAnn sTvs
, hst_xforall = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) rho
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs') rho
}
-- | Process a 'Type' which starts with an invisible @forall@ or a constraint
@@ -948,18 +950,18 @@ synifyVisForAllType vs ty =
synifySigmaType
:: SynifyTypeState
-- ^ what to do with the 'forall'
- -> [TyVar]
- -- ^ free variables in the type to convert
+ -> TyVarSet
+ -- ^ bound type variables
-> Type
-- ^ the forall type to convert
-> LHsType GhcRn
-synifySigmaType s vs ty =
+synifySigmaType s boundTvs ty =
let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty
sPhi =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synifyType WithinType (tvs' ++ vs) tau
+ , hst_body = synifyType WithinType (extendVarSetList boundTvs tvs' ) tau
}
sTy =
@@ -969,49 +971,56 @@ synifySigmaType s vs ty =
, hst_body = noLocA sPhi
}
- sTvs = map synifyTyVarBndr tvs
+ sTvs = map (synifyTyVarBndr' noKindSigTvs) tvs
+
+ noKindSigTvs = noKindSigTyVars ty
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ tvs' = orderedFVs boundTvs (ctx ++ [tau])
in case s of
- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau
+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (extendVarSetList boundTvs tvs') tau
-- Put a forall in if there are any type variables
WithinType
| not (null tvs) -> noLocA sTy
| otherwise -> noLocA sPhi
- ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau
+ ImplicitizeForAll -> implicitForAll boundTvs tvs ctx (synifyType WithinType) tau
--- | Put a forall in if there are any type variables which require
--- explicit kind annotations or if the inferred type variable order
--- would be different.
+-- | Use an explicit forall if there are any type variables which require
+-- explicit kind annotations or if the inferred type variable quantification
+-- order would be different.
implicitForAll
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> [TyVar]
- -- ^ free variables in the type to convert
+ :: TyVarSet
+ -- ^ bound type variables (e.g. bound from an outer scope)
-> [InvisTVBinder]
-- ^ type variable binders in the forall
-> ThetaType
-- ^ constraints right after the forall
- -> ([TyVar] -> Type -> LHsType GhcRn)
+ -> (TyVarSet -> Type -> LHsType GhcRn)
-- ^ how to convert the inner type
-> Type
-- ^ inner type
-> LHsType GhcRn
-implicitForAll tycons vs tvs ctx synInner tau
- | any (isHsKindedTyVar . unLoc) sTvs = noLocA sTy
- | tvs' /= (binderVars tvs) = noLocA sTy
- | otherwise = noLocA sPhi
+implicitForAll boundTvs tvbs ctx synInner tau
+ | any (isHsKindedTyVar . unLoc) sTvs
+ -- Explicit forall: some type variable needs an explicit kind annotation.
+ = noLocA sTy
+ | tvs /= inferredFreeTvs
+ -- Explicit forall: the inferred quantification order would be different.
+ = noLocA sTy
+ | otherwise
+ -- Implicit forall.
+ = noLocA sPhi
where
- sRho = synInner (tvs' ++ vs) tau
+ tvs = binderVars tvbs
+ sRho = synInner (extendVarSetList boundTvs inferredFreeTvs) tau
sPhi
| null ctx = unLoc sRho
| otherwise =
HsQualTy
{ hst_ctxt = synifyCtx ctx
, hst_xqual = noExtField
- , hst_body = synInner (tvs' ++ vs) tau
+ , hst_body = sRho
}
sTy =
HsForAllTy
@@ -1020,84 +1029,129 @@ implicitForAll tycons vs tvs ctx synInner tau
, hst_body = noLocA sPhi
}
- no_kinds_needed = noKindTyVars tycons tau
- sTvs = map (synifyTyVarBndr' no_kinds_needed) tvs
+ no_kinds_needed = noKindSigTyVars tau
+ sTvs = map (synifyTyVarBndr' no_kinds_needed) tvbs
-- Figure out what the type variable order would be inferred in the
-- absence of an explicit forall
- tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau])
+ inferredFreeTvs = orderedFVs boundTvs (ctx ++ [tau])
--- | Find the set of type variables whose kind signatures can be properly
--- inferred just from their uses in the type signature. This means the type
--- variable to has at least one fully applied use @f x1 x2 ... xn@ where:
+-- | Returns a subset of the free type variables of the given type whose kinds
+-- can definitely be inferred from their occurrences in the type.
--
--- * @f@ has a function kind where the arguments have the same kinds
--- as @x1 x2 ... xn@.
+-- This function is only a simple heuristic, which is used in order to avoid
+-- needlessly cluttering Haddocks with explicit foralls that are not needed.
+-- This function may return some type variables for which we aren't sure
+-- (which will cause us to display the type with an explicit forall, just in
+-- case).
--
--- * @f@ has a function kind whose final return has lifted type kind
-noKindTyVars
- :: [TyCon]
- -- ^ type constructors that determine their args kinds
- -> Type
+-- In the future, we hope to address the issue of whether to print a type with
+-- an explicit forall by storing whether the user wrote the type with an
+-- explicit forall in the first place (see GHC ticket #26271).
+noKindSigTyVars
+ :: Type
-- ^ type to inspect
-> VarSet
- -- ^ set of variables whose kinds can be inferred from uses in the type
-noKindTyVars _ (TyVarTy var)
- | isLiftedTypeKind (tyVarKind var) = unitVarSet var
-noKindTyVars ts ty
- | (f, xs) <- splitAppTys ty
- , not (null xs) =
- let args = map (noKindTyVars ts) xs
- func = case f of
- TyVarTy var
- | (xsKinds, outKind) <- splitFunTys (tyVarKind var)
- , map scaledThing xsKinds `eqTypes` map typeKind xs
- , isLiftedTypeKind outKind ->
- unitVarSet var
- TyConApp t ks
- | t `elem` ts
- , all noFreeVarsOfType ks ->
- mkVarSet [v | TyVarTy v <- xs]
- _ -> noKindTyVars ts f
- in unionVarSets (func : args)
-noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t
-noKindTyVars ts (FunTy _ w t1 t2) =
- noKindTyVars ts w
- `unionVarSet` noKindTyVars ts t1
- `unionVarSet` noKindTyVars ts t2
-noKindTyVars ts (CastTy t _) = noKindTyVars ts t
-noKindTyVars _ _ = emptyVarSet
-
-synifyMultArrow :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultArrow vs t = case t of
+ -- ^ set of variables whose kinds can definitely be inferred from occurrences in the type
+noKindSigTyVars ty
+ | Just ty' <- coreView ty
+ = noKindSigTyVars ty'
+ -- In a TyConApp 'T ty_1 ... ty_n', if 'ty_i = tv' is a type variable and the
+ -- i-th argument of the kind of 'T' is monomorphic, then the kind of 'tv'
+ -- is fully determined by its occurrence in the TyConApp.
+ | Just (tc, args) <- splitTyConApp_maybe ty
+ , let (tcArgBndrs, _tcResKi) = splitPiTys (tyConKind tc)
+ tcArgKis = map (\case { Named (Bndr b _) -> tyVarKind b; Anon (Scaled _ t) _ -> t}) tcArgBndrs
+ = mono_tvs tcArgKis args `unionVarSet` (mapUnionVarSet noKindSigTyVars args)
+ -- If we have 'f ty_1 ... ty_n' where 'f :: ki_1 -> ... -> ki_n -> Type'
+ -- then we can infer the kind of 'f' from the kinds of its arguments.
+ --
+ -- This special case handles common examples involving functors, monads...
+ -- with type signatures such as '(a -> b) -> (f a -> f b)'.
+ | (TyVarTy fun, args) <- splitAppTys ty
+ , not (null args)
+ , (funArgKinds, funResKind) <- splitFunTys (tyVarKind fun)
+ , map scaledThing funArgKinds `eqTypes` map typeKind args
+ , isLiftedTypeKind funResKind
+ = ( `extendVarSet` fun ) $ mapUnionVarSet noKindSigTyVars args
+ where
+ mono_tvs :: [Type] -> [Type] -> VarSet
+ mono_tvs (tcArgKi:tcArgKis) (arg:args)
+ | TyVarTy arg_tv <- arg
+ , noFreeVarsOfType tcArgKi
+ = ( `extendVarSet` arg_tv ) $ mono_tvs tcArgKis args
+ | otherwise
+ = mono_tvs tcArgKis args
+ mono_tvs _ _ = emptyVarSet
+noKindSigTyVars (ForAllTy _ t) = noKindSigTyVars t
+noKindSigTyVars (CastTy t _) = noKindSigTyVars t
+noKindSigTyVars _ = emptyVarSet
+
+synifyMultArrow :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultArrow boundTvs t = case t of
OneTy -> HsLinearAnn noExtField
ManyTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
-synifyMultRec :: [TyVar] -> Mult -> HsMultAnn GhcRn
-synifyMultRec vs t = case t of
+synifyMultRec :: TyVarSet -> Mult -> HsMultAnn GhcRn
+synifyMultRec boundTvs t = case t of
OneTy -> HsUnannotated noExtField
- ty -> HsExplicitMult noExtField (synifyType WithinType vs ty)
+ ty -> HsExplicitMult noExtField (synifyType WithinType boundTvs ty)
synifyPatSynType :: PatSyn -> LHsType GhcRn
synifyPatSynType ps =
- let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
- ts = maybeToList (tyConAppTyCon_maybe res_ty)
+ let (univ_tvbs, req_theta, ex_tvbs, prov_theta, arg_tys, res_ty) = patSynSigBndr ps
+
+{- Recall that pattern synonyms have both "required" and "provided" constraints,
+e.g.
+
+ pattern P :: forall a b c. req => forall e f g => prov => arg_ty1 -> ... -> res_ty
+
+Here:
+
+ a, b, c are universal type variables
+ req are required constraints
- -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>",
- -- i.e., an explicit empty context, which is what we need. This is not
- -- possible by taking theta = [], as that will print no context at all
+ e, f, g are existential type variables
+ prov are provided constraints
+
+The first pair comes from the outside, while the second pair is obtained upon
+a successful match on the pattern.
+
+Remarks:
+
+ 1. Both foralls are optional.
+
+ 2. If there is only one =>, we interpret the constraints as required.
+ Thus, if we want an empty set of required constraints and a non-empty set
+ of provided constraints, the type signature must be written like
+
+ () => prov => res_ty
+-}
+
+
+ -- Add an explicit "() => ..." when req_theta is empty but there are
+ -- existential variables or provided constraints.
req_theta'
| null req_theta
- , not (null prov_theta && null ex_tvs) =
+ , not (null prov_theta && null ex_tvbs) =
[unitTy]
| otherwise = req_theta
+ univ_tvs = mkVarSet $ binderVars univ_tvbs
+ ex_tvs = mkVarSet $ binderVars ex_tvbs
+
+
in implicitForAll
- ts
- []
- (univ_tvs ++ ex_tvs)
+ ex_tvs -- consider the ex_tvs non-free, so that we don't quantify over them here
+ univ_tvbs -- quantify only over the universals
req_theta'
- (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType))
+ ( \_ ->
+ implicitForAll
+ univ_tvs -- the univ_tvs are already bound
+ ex_tvbs -- quantify only over the existentials
+ prov_theta
+ (synifyType WithinType)
+ )
(mkScaledFunTys arg_tys res_ty)
synifyTyLit :: TyLit -> HsTyLit GhcRn
@@ -1106,7 +1160,7 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s
synifyTyLit (CharTyLit c) = HsCharTy NoSourceText c
synifyKindSig :: Kind -> LHsKind GhcRn
-synifyKindSig k = synifyType WithinType [] k
+synifyKindSig k = synifyType WithinType emptyVarSet k
stripKindSig :: LHsType GhcRn -> LHsType GhcRn
stripKindSig (L _ (HsKindSig _ t _)) = t
@@ -1119,7 +1173,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
, ihdTypes = map unLoc annot_ts
, ihdInstType =
ClassInst
- { clsiCtx = map (unLoc . synifyType WithinType []) preds
+ { clsiCtx = map (unLoc . synifyType WithinType emptyVarSet) preds
, clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon)
, clsiSigs = map synifyClsIdSig $ specialized_class_methods
, clsiAssocTys =
@@ -1132,7 +1186,7 @@ synifyInstHead (vs, preds, cls, types) associated_families =
where
cls_tycon = classTyCon cls
ts = filterOutInvisibleTypes cls_tycon types
- ts' = map (synifyType WithinType vs) ts
+ ts' = map (synifyType WithinType $ mkVarSet vs) ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded cls_tycon
synifyClsIdSig = synifyIdSig ShowRuntimeRep DeleteTopLevelQuantification vs
@@ -1151,7 +1205,7 @@ synifyFamInst fi opaque = do
where
ityp SynFamilyInst | opaque = return $ TypeInst Nothing
ityp SynFamilyInst =
- return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs
+ return . TypeInst . Just . unLoc $ synifyType WithinType emptyVarSet fam_rhs
ityp (DataFamilyInst c) =
DataInst <$> synifyTyCon HideRuntimeRep (Just $ famInstAxiom fi) c
fam_tc = famInstTyCon fi
@@ -1173,7 +1227,7 @@ synifyFamInst fi opaque = do
fam_lhs
ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs
- synifyTypes = map (synifyType WithinType [])
+ synifyTypes = map (synifyType WithinType emptyVarSet)
ts' = synifyTypes ts
annot_ts = zipWith3 annotHsType args_poly ts ts'
args_poly = tyConArgsPolyKinded fam_tc
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -856,8 +856,8 @@ tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c
tyCoFVsOfType' (LitTy{}) a b c = emptyFV a b c
tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c
tyCoFVsOfType' (FunTy _ w arg res) a b c =
- ( tyCoFVsOfType' w
- `unionFV` tyCoFVsOfType' res
+ ( tyCoFVsOfType' res
+ `unionFV` tyCoFVsOfType' w
`unionFV` tyCoFVsOfType' arg
)
a
=====================================
utils/haddock/html-test/ref/Bug1050.html
=====================================
@@ -99,11 +99,7 @@
>mkT</a
> :: <span class="keyword"
>forall</span
- > {k} {f :: <span class="keyword"
- >forall</span
- > k1. k1 -> <a href="#" title="Data.Kind"
- >Type</a
- >} {a :: k}. f a -> <a href="#" title="Bug1050"
+ > {k} {f} {a :: k}. f a -> <a href="#" title="Bug1050"
>T</a
> f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/LinearTypes.html
=====================================
@@ -64,11 +64,7 @@
><li class="src short"
><a href="#"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b</li
+ > :: a %m -> b</li
><li class="src short"
><span class="keyword"
>data</span
@@ -163,11 +159,7 @@
><p class="src"
><a id="v:poly" class="def"
>poly</a
- > :: <span class="keyword"
- >forall</span
- > a (m :: <a href="#" title="GHC.Exts"
- >Multiplicity</a
- >) b. a %m -> b <a href="#" class="selflink"
+ > :: a %m -> b <a href="#" class="selflink"
>#</a
></p
><div class="doc"
=====================================
utils/haddock/html-test/ref/PatternSyns.html
=====================================
@@ -132,7 +132,9 @@
>pattern</span
> <a href="#"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b</li
><li class="src short"
@@ -335,7 +337,9 @@
>pattern</span
> <a id="v:E" class="def"
>E</a
- > :: a <a href="#" title="PatternSyns"
+ > :: <span class="keyword"
+ >forall</span
+ > {k} {a} {b :: k}. a <a href="#" title="PatternSyns"
>><</a
> b <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/ref/PatternSyns2.html
=====================================
@@ -0,0 +1,160 @@
+<html xmlns="http://www.w3.org/1999/xhtml"
+><head
+ ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"
+ /><meta name="viewport" content="width=device-width, initial-scale=1"
+ /><title
+ >PatternSyns2</title
+ ><link href="#" rel="stylesheet" type="text/css" title="Linuwial"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><link rel="stylesheet" type="text/css" href="#"
+ /><script src="haddock-bundle.min.js" async="async" type="text/javascript"
+ ></script
+ ><script type="text/x-mathjax-config"
+ >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script
+ ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript"
+ ></script
+ ></head
+ ><body
+ ><div id="package-header"
+ ><span class="caption empty"
+ > </span
+ ><ul class="links" id="page-menu"
+ ><li
+ ><a href="#"
+ >Contents</a
+ ></li
+ ><li
+ ><a href="#"
+ >Index</a
+ ></li
+ ></ul
+ ></div
+ ><div id="content"
+ ><div id="module-header"
+ ><table class="info"
+ ><tr
+ ><th
+ >Safe Haskell</th
+ ><td
+ >None</td
+ ></tr
+ ><tr
+ ><th
+ >Language</th
+ ><td
+ >Haskell2010</td
+ ></tr
+ ></table
+ ><p class="caption"
+ >PatternSyns2</p
+ ></div
+ ><div id="interface"
+ ><h1
+ >Documentation</h1
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P1" class="def"
+ >P1</a
+ > :: () => <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> D <a href="#" title="Prelude"
+ >Num</a
+ > a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P2" class="def"
+ >P2</a
+ > :: <a href="#" title="Prelude"
+ >Num</a
+ > a => a -> a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P3" class="def"
+ >P3</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P4" class="def"
+ >P4</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). <span class="breakable"
+ >(<span class="unbreakable"
+ >PCIR a</span
+ >, <span class="unbreakable"
+ >PCDR e</span
+ >)</span
+ > => a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P5" class="def"
+ >P5</a
+ > :: RCIR a => <span class="keyword"
+ >forall</span
+ > (e :: <a href="#" title="GHC.Exts"
+ >TYPE</a
+ > '<a href="#" title="GHC.Exts"
+ >DoubleRep</a
+ >). a -> e -> Q a <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ><div class="top"
+ ><p class="src"
+ ><span class="keyword"
+ >pattern</span
+ > <a id="v:P" class="def"
+ >P</a
+ > :: () => <span class="keyword"
+ >forall</span
+ > k (a :: k) b. <a href="#" title="Prelude"
+ >Show</a
+ > b => <a href="#" title="Data.Proxy"
+ >Proxy</a
+ > a -> b -> A <a href="#" class="selflink"
+ >#</a
+ ></p
+ ></div
+ ></div
+ ></div
+ ></body
+ ></html
+>
=====================================
utils/haddock/html-test/ref/TypeOperators.html
=====================================
@@ -185,17 +185,7 @@
><p class="src"
><a id="v:biO" class="def"
>biO</a
- > :: <span class="keyword"
- >forall</span
- > (g :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) (f :: <a href="#" title="Data.Kind"
- >Type</a
- > -> <a href="#" title="Data.Kind"
- >Type</a
- >) a. <a href="#" title="TypeOperators"
+ > :: <a href="#" title="TypeOperators"
>O</a
> g f a <a href="#" class="selflink"
>#</a
=====================================
utils/haddock/html-test/src/PatternSyns2.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE Haskell2010 #-}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+
+module PatternSyns2
+ ( pattern P1, pattern P2, pattern P3, pattern P4, pattern P5
+ , pattern P
+ )
+ where
+
+import Data.Kind
+import Data.Proxy
+import GHC.Exts
+
+type D :: ( Type -> Constraint ) -> Type -> Type
+data D c a where
+ MkD :: c a => a -> D c a
+
+pattern P1 :: () => Num a => a -> D Num a
+pattern P1 a = MkD a
+
+pattern P2 :: Num a => () => a -> a
+pattern P2 a = a
+
+type RCIR :: TYPE IntRep -> Constraint
+class RCIR a where
+
+type PCIR :: TYPE IntRep -> Constraint
+class PCIR a where
+
+type PCDR :: TYPE DoubleRep -> Constraint
+class PCDR a where
+
+type Q :: TYPE IntRep -> Type
+data Q a where
+ MkQ :: forall ( a :: TYPE IntRep ) ( e :: TYPE DoubleRep )
+ . ( PCIR a, PCDR e )
+ => a -> e -> Q a
+
+pattern P3 :: forall (a :: TYPE IntRep). () => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P3 a e = MkQ a e
+
+pattern P4 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). (PCIR a, PCDR e) => a -> e -> Q a
+pattern P4 a e = MkQ a e
+
+pattern P5 :: forall (a :: TYPE IntRep). (RCIR a) => forall (e :: TYPE DoubleRep). () => a -> e -> Q a
+pattern P5 a e <- MkQ a e
+
+
+type A :: Type
+data A where
+ MkA :: forall k (a ::k) b. ( Show b ) => Proxy a -> b -> A
+
+pattern P :: forall . () => forall k (a :: k) b. ( Show b ) => Proxy a -> b -> A
+pattern P a b = MkA a b
=====================================
utils/haddock/latex-test/ref/LinearTypes/LinearTypes.tex
=====================================
@@ -24,7 +24,7 @@ Does something linear.\par}
\end{haddockdesc}
\begin{haddockdesc}
\item[\begin{tabular}{@{}l}
-poly :: forall a (m :: Multiplicity) b. a {\char '45}m -> b
+poly :: a {\char '45}m -> b
\end{tabular}]
{\haddockbegindoc
Does something polymorphic.\par}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28deff1eb75c9fa8e279b1901bad0b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28deff1eb75c9fa8e279b1901bad0b…
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] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/mwb-perf-tuning-2 at Glasgow Haskell Compiler / GHC
Commits:
c4f061fb by Torsten Schmits at 2025-12-11T19:20:41+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
55719a63 by Torsten Schmits at 2025-12-11T19:21:23+01:00
Abstract out module provider queries into a handler type
- - - - -
d76b2001 by Torsten Schmits at 2025-12-11T19:21:23+01:00
Use unit index for name printing
- - - - -
22 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/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/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.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 (hscUnitIndex hsc_env) (hscActiveUnitId 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
=====================================
@@ -189,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
@@ -512,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
@@ -2397,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/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
@@ -482,6 +484,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
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
=====================================
@@ -68,11 +68,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 +206,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 +218,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
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -68,7 +68,7 @@ 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
@@ -164,18 +164,20 @@ findImportedModule hsc_env mod pkg_qual =
fopts = initFinderOpts dflags
in do
let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env)
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery 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 home_module_map 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
@@ -201,7 +203,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map 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 home_module_map (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 =
@@ -212,11 +214,11 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
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
@@ -241,13 +243,13 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg =
-- 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
@@ -303,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/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,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 <$> findOrigin query 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 +646,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})
@@ -1484,9 +1492,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 +1552,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 -> readDatabases index 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.
@@ -1562,15 +1566,20 @@ 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
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
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
@@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do
$ 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
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do
, 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 +1902,76 @@ 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),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ 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 :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1979,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 +2010,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 +2043,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 findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2118,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 (moduleProviders query 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 (moduleProviders query 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
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> 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
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_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} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afa9ff5f3bb30119e68b8e96fecd02…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/afa9ff5f3bb30119e68b8e96fecd02…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-mwb] 3 commits: Abstract out parts of mkUnitState into a handler type
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
by Torsten Schmits (＠torsten.schmits) 11 Dec '25
11 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC
Commits:
0f53689d by Torsten Schmits at 2025-12-11T19:18:07+01:00
Abstract out parts of mkUnitState into a handler type
- - - - -
e8fbabcf by Torsten Schmits at 2025-12-11T19:18:07+01:00
Abstract out module provider queries into a handler type
- - - - -
1a9ec6e8 by Torsten Schmits at 2025-12-11T19:18:07+01:00
Use unit index for name printing
- - - - -
22 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/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/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.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 (hscUnitIndex hsc_env) (hscActiveUnitId 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
=====================================
@@ -187,12 +187,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
@@ -510,15 +511,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
@@ -2384,7 +2385,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/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
@@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [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
=====================================
@@ -68,11 +68,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 +206,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 +218,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
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -67,7 +67,7 @@ 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 qualified Data.Set as Set
@@ -161,17 +161,19 @@ 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
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -193,7 +195,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 (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
| mod_name `Set.member` finder_hiddenModules opts =
return (mkHomeHidden uid)
| otherwise =
@@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ 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
@@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- 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 +285,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/State.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow, 2006
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where
(if null rhs
then []
else [text "hidden reexport by" <+>
- sep (map (ppr . mkUnit) res)]) ++
+ sep (map (ppr . mkUnit) rhs)]) ++
(if f then [text "package flag"] else [])
))
@@ -577,10 +585,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 <$> findOrigin query 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 +646,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})
@@ -1484,9 +1492,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 +1552,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 -> readDatabases index 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.
@@ -1562,15 +1566,20 @@ 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
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do
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
@@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do
$ 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
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList 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 +1902,76 @@ 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),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ 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 :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +1979,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 +2010,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 +2043,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 findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2118,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 (moduleProviders query 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 (moduleProviders query 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
=====================================
@@ -839,12 +839,13 @@ initMulti unitArgsFiles = do
let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
home_units = unitEnv_keys initial_home_graph
+ ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> 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
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_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} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/666a8c2ea59e1cd3eed8d4254a74db…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/666a8c2ea59e1cd3eed8d4254a74db…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
1dd5d86a by Simon Peyton Jones at 2025-12-11T13:49:57+00:00
Wibbles
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -26,8 +26,8 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind
import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
import qualified GHC.Core.Make
import GHC.Core.Coercion hiding ( substCo, substCoVar )
-import GHC.Core.Reduction
import GHC.Core.Coercion.Opt ( optCoercion )
+import GHC.Core.Reduction
import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
import GHC.Core.DataCon
import GHC.Core.Opt.Stats ( Tick(..) )
@@ -35,8 +35,7 @@ import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe
- , pushCoTyArg, pushCoValArg, exprIsDeadEnd
- , typeArity, arityTypeArity, etaExpandAT )
+ , exprIsDeadEnd, typeArity, arityTypeArity, etaExpandAT )
import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} )
import GHC.Core.Rules ( lookupRule, getRules )
@@ -1676,70 +1675,12 @@ optOutCoercion env co already_optimised
simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont
-> SimplM (SimplFloats, OutExpr)
simplCast env body co0 cont0
- = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
- ; cont1 <- {-#SCC "simplCast-addCoerce" #-}
- if isReflCo co1
- then return cont0 -- See Note [Optimising reflexivity]
- else addCoerce co1 True cont0
+ = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
+ ; let cont1 = {-#SCC "simplCast-addCoerce" #-}
+ pushCastCont env co1 True cont0
-- True <=> co1 is optimised
- ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
- where
-
- -- If the first parameter is MRefl, then simplifying revealed a
- -- reflexive coercion. Omit.
- addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
- addCoerceM MRefl _ cont = return cont
- addCoerceM (MCo co) opt cont = addCoerce co opt cont
-
- addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont
- addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity]
- = addCoerce (mkTransCo co1 co2) False cont
- -- False: (mkTransCo co1 co2) is not fully optimised
- -- See Note [Avoid re-simplifying coercions]
-
- addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
- | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
- = {-#SCC "addCoerce-pushCoTyArg" #-}
- do { tail' <- addCoerceM m_co' co_is_opt tail
- ; return (ApplyToTy { sc_arg_ty = arg_ty'
- , sc_cont = tail'
- , sc_hole_ty = coercionLKind co }) }
- -- NB! As the cast goes past, the
- -- type of the hole changes (#16312)
- -- (f |> co) e ===> (f (e |> co1)) |> co2
- -- where co :: (s1->s2) ~ (t1->t2)
- -- co1 :: t1 ~ s1
- -- co2 :: s2 ~ t2
- addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg_clo
- , sc_dup = dup, sc_cont = tail })
- | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first
- = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont
-
- | Just (m_co1, m_co2) <- pushCoValArg co
- = {-#SCC "addCoerce-pushCoValArg" #-}
- do { tail' <- addCoerceM m_co2 co_is_opt tail
- ; case m_co1 of {
- MRefl -> return (cont { sc_cont = tail'
- , sc_hole_ty = coercionLKind co }) ;
- -- See Note [Avoiding simplifying repeatedly]
-
- MCo co1 ->
- do { let arg_clo' = case arg_clo of
- DoneId v -> DoneEx (Cast (Var v) co1) NotJoinPoint
- DoneEx e _jp -> DoneEx (Cast e co1) NotJoinPoint
- ContEx se e mco -> ContEx se e (mkTransMCoL mco co1)
-
- ; return (ApplyToVal { sc_arg = arg_clo'
- , sc_dup = dup
- , sc_cont = tail'
- , sc_hole_ty = coercionLKind co }) } } }
-
- addCoerce co co_is_opt cont
- | isReflCo co = return cont -- Having this at the end makes a huge
- -- difference in T12227, for some reason
- -- See Note [Optimising reflexivity]
- | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })
+ ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
{-
************************************************************************
@@ -1870,7 +1811,7 @@ simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont
is_strict_bind
= -- Evaluate RHS strictly
simplExprF (rhs_se `setInScopeFromE` env) rhs
- (pushCastCont mco $
+ (pushCastMCont env mco True $
StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
, sc_env = env, sc_cont = cont, sc_dup = NoDup })
@@ -2226,7 +2167,7 @@ simplClo :: SimplEnv
simplClo env clo cont
= case clo of
ContEx se e mco -> simplExprF (se `setInScopeFromE` env) e $
- pushCastCont mco cont
+ pushCastMCont env mco True cont
-- Don't trimJoinCont; we haven't already simplified e,
-- so the cont is not embodied in e
@@ -2247,7 +2188,7 @@ simplCloArg :: SimplEnvIS -- ^ Used only for its InScopeSet
-> SimplClo
-> SimplM OutExpr
simplCloArg env fun_ty mb_arg_info (ContEx arg_se arg mco)
- = simplExprC arg_env arg (pushCastCont mco stop)
+ = simplExprC arg_env arg (pushCastMCont env mco True stop)
where
arg_env = arg_se `setInScopeFromE` env
arg_ty = funArgTy fun_ty
@@ -2393,7 +2334,7 @@ rebuildCall env fun_info
, seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
-- Note [Case-of-case and full laziness]
-> simplExprF (arg_se `setInScopeFromE` env) in_arg
- (pushCastCont mco $
+ (pushCastMCont env mco True $
StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
, sc_dup = NoDup, sc_cont = cont })
-- Note [Shadowing in the Simplifier]
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -29,7 +29,7 @@ module GHC.Core.Opt.Simplify.Utils (
contIsTrivial, contArgs, contIsRhs,
countArgs, contOutArgs, dropContArgs,
mkBoringStop, mkRhsStop, mkLazyArgStop,
- interestingCallContext, pushCastCont,
+ interestingCallContext, pushCastCont, pushCastMCont,
-- ArgInfo
ArgInfo(..), ArgSpec(..), mkArgInfo,
@@ -63,6 +63,7 @@ import GHC.Core.Unfold.Make
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Type hiding( substTy )
import GHC.Core.Coercion hiding( substCo )
+import GHC.Core.Coercion.Opt ( optCoercion )
import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
import GHC.Core.Multiplicity
import GHC.Core.Opt.ConstantFold
@@ -415,11 +416,6 @@ mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd
where
arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
-pushCastCont :: MOutCoercion -> SimplCont -> SimplCont
--- Assumes the MOutCoercion is optimised
-pushCastCont MRefl cont = cont
-pushCastCont (MCo co) cont = CastIt { sc_co = co, sc_opt = True, sc_cont = cont }
-
-------------------
contIsRhs :: SimplCont -> Maybe RecFlag
contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec
@@ -704,6 +700,63 @@ make use of the strictness info for the function.
-}
+{- *********************************************************************
+* *
+ Pushing a cast onto a continuation
+* *
+********************************************************************* -}
+
+pushCastMCont :: SimplEnvIS -> MOutCoercion -> Bool -> SimplCont -> SimplCont
+-- Bool = True <=> the coercion is already optimised
+pushCastMCont _ MRefl _ cont = cont
+pushCastMCont env (MCo co) opt cont = pushCastCont env co opt cont
+
+pushCastCont :: SimplEnvIS -> OutCoercion -> Bool -> SimplCont -> SimplCont
+pushCastCont _env co _opt cont
+ | isReflCo co -- isReflCo is cheap
+ = cont -- Having this test made a huge difference in T12227, for some reason
+ -- See Note [Optimising reflexivity]
+
+pushCastCont env co _opt (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity]
+ = pushCastCont env (mkTransCo co co2) False cont
+ -- False: (mkTransCo co co2) is not fully optimised
+ -- See Note [Avoid re-simplifying coercions]
+
+pushCastCont env co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
+ | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+ = {-#SCC "addCoerce-pushCoTyArg" #-}
+ ApplyToTy { sc_arg_ty = arg_ty'
+ , sc_hole_ty = coercionLKind co
+ , sc_cont = pushCastMCont env m_co' opt tail }
+ -- sc_hole_ty: As the cast goes past, the hole type changes (#16312)
+
+pushCastCont env co opt cont@(ApplyToVal {})
+ | not opt -- pushCoValArg duplicates the coercion, so optimise first
+ = pushCastCont env (optCoercion opts empty_subst co) True cont
+ where
+ empty_subst = mkEmptySubst (seInScope env)
+ opts = seOptCoercionOpts env
+
+pushCastCont env co _opt (ApplyToVal { sc_arg = clo, sc_dup = dup, sc_cont = tail })
+ | Just (m_co1, m_co2) <- pushCoValArg co
+ = -- (f |> co) e ===> (f (e |> co1)) |> co2
+ -- where co :: (s1->s2) ~ (t1->t2)
+ -- co1 :: t1 ~ s1
+ -- co2 :: s2 ~ t2
+ ApplyToVal { sc_arg = mkCloCastMCo clo m_co1
+ , sc_dup = dup
+ , sc_hole_ty = coercionLKind co
+ , sc_cont = pushCastMCont env m_co2 True tail }
+
+pushCastCont _env co opt cont
+ = CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }
+
+mkCloCastMCo :: SimplClo -> MOutCoercion -> SimplClo
+mkCloCastMCo clo MRefl = clo
+mkCloCastMCo (DoneId v) (MCo co) = DoneEx (Cast (Var v) co) NotJoinPoint
+mkCloCastMCo (DoneEx e _jp) (MCo co) = DoneEx (Cast e co) NotJoinPoint
+mkCloCastMCo (ContEx se e mco) (MCo co) = ContEx se e (mkTransMCoL mco co)
+
{-
************************************************************************
* *
@@ -1859,7 +1912,9 @@ rebuildLam _env [] body _cont
= return body
rebuildLam env bndrs@(bndr:_) body cont
- = {-# SCC "rebuildLam" #-} try_eta bndrs body
+ = {-# SCC "rebuildLam" #-}
+ do { traceSmpl "rebuildLam" (ppr bndrs $$ ppr cont)
+ ; try_eta bndrs body }
where
rec_ids = seRecIds env
in_scope = getInScope env -- Includes 'bndrs'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd5d86a6d9b33d2f7507d0ec074cba…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1dd5d86a6d9b33d2f7507d0ec074cba…
You're receiving this email because of your account on gitlab.haskell.org.
1
0