[Git][ghc/ghc] Pushed new branch wip/mp/no_implicit_reqs
by Matthew Pickering (＠mpickering) 03 Dec '25
by Matthew Pickering (＠mpickering) 03 Dec '25
03 Dec '25
Matthew Pickering pushed new branch wip/mp/no_implicit_reqs at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mp/no_implicit_reqs
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26519] 9 commits: gitlab-ci: Run ghcup-metadata jobs on OpenCape runners
by Peter Trommler (＠trommler) 03 Dec '25
by Peter Trommler (＠trommler) 03 Dec '25
03 Dec '25
Peter Trommler pushed to branch wip/T26519 at Glasgow Haskell Compiler / GHC
Commits:
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.
- - - - -
ca7724a1 by Peter Trommler at 2025-12-03T06:37:17+01:00
PPC NCG: Fix shift right MO code
The shift amount in shift right [arithmetic] MOs is machine word
width. Thereifore remove zero- or sign-entend shift amount.
It looks harmless to extend the shift amount argument because the
shift right instruction uses only the seven lowest bits (i. e. mod 128).
But now we have a conversion operation from a smaller type to word width
around a memory load at word width. The types are not matching up but
there is no check done in CodeGen. The necessary conversion from word
width down to the smaller width would be translated into a no-op on
PowerPC anyway. So all seems harmless if it was not for a small
optimisation in getRegister'.
In getRegister' a load instruction with the smaller width of the
conversion operation was generated. This the loaded the most significant
bits of the word in memory on a big-endian platform. These bits were
zero and hence shift right was used with shift amount zero and not one
as required in test Sized.
Fixes #26519
- - - - -
124 changed files:
- .gitlab-ci.yml
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Data/OsPath.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Outputable.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/exts/data_kinds.rst
- docs/users_guide/exts/explicit_namespaces.rst
- ghc/GHCi/UI.hs
- ghc/Main.hs
- hadrian/src/Settings.hs
- hadrian/src/Settings/Warnings.hs
- libraries/base/changelog.md
- libraries/ghc-boot-th/GHC/Boot/TH/Ppr.hs
- libraries/ghc-internal/src/GHC/Internal/Float.hs
- libraries/ghc-internal/src/GHC/Internal/List.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Posix.hs
- libraries/template-haskell/vendored-filepath/System/FilePath/Windows.hs
- rts/linker/Elf.c
- testsuite/tests/driver/j-space/jspace.hs
- + testsuite/tests/module/T25901_exp_plain_wc.hs
- + testsuite/tests/module/T25901_exp_plain_wc.stderr
- + testsuite/tests/module/T25901_imp_plain_wc.hs
- + testsuite/tests/module/T25901_imp_plain_wc.stderr
- testsuite/tests/module/all.T
- + testsuite/tests/rename/should_compile/T25901_exp_1.hs
- + testsuite/tests/rename/should_compile/T25901_exp_1_helper.hs
- + testsuite/tests/rename/should_compile/T25901_exp_2.hs
- + testsuite/tests/rename/should_compile/T25901_exp_2_helper.hs
- + testsuite/tests/rename/should_compile/T25901_imp_hq.hs
- + testsuite/tests/rename/should_compile/T25901_imp_hu.hs
- + testsuite/tests/rename/should_compile/T25901_imp_sq.hs
- + testsuite/tests/rename/should_compile/T25901_imp_su.hs
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/rename/should_fail/T25901_exp_fail_1.hs
- + testsuite/tests/rename/should_fail/T25901_exp_fail_1.stderr
- + testsuite/tests/rename/should_fail/T25901_exp_fail_1_helper.hs
- + testsuite/tests/rename/should_fail/T25901_exp_fail_2.hs
- + testsuite/tests/rename/should_fail/T25901_exp_fail_2.stderr
- + testsuite/tests/rename/should_fail/T25901_exp_fail_2_helper.hs
- + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.hs
- + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_5.stderr
- + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.hs
- + testsuite/tests/rename/should_fail/T25901_imp_hq_fail_6.stderr
- + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.hs
- + testsuite/tests/rename/should_fail/T25901_imp_hu_fail_4.stderr
- + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.hs
- + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_2.stderr
- + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.hs
- + testsuite/tests/rename/should_fail/T25901_imp_sq_fail_3.stderr
- + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.hs
- + testsuite/tests/rename/should_fail/T25901_imp_su_fail_1.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rts/KeepCafsBase.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dodgy.stderr
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_1.stderr
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_2.stderr
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_3.stderr
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.hs
- + testsuite/tests/warnings/should_compile/T25901_exp_dup_wc_4.stderr
- + testsuite/tests/warnings/should_compile/T25901_helper_1.hs
- + testsuite/tests/warnings/should_compile/T25901_helper_2.hs
- + testsuite/tests/warnings/should_compile/T25901_helper_3.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_1.stderr
- + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_dodgy_2.stderr
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_1.stderr
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_2.stderr
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_3.stderr
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.hs
- + testsuite/tests/warnings/should_compile/T25901_imp_unused_4.stderr
- testsuite/tests/warnings/should_compile/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
- utils/ghc-pkg/Main.hs
- utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml.hs
- utils/haddock/haddock-library/src/Documentation/Haddock/Parser.hs
- utils/hpc
- utils/hsc2hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a9ee3c55a78ba84dfbc975a548e3d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4a9ee3c55a78ba84dfbc975a548e3d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
03 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
e02bbc62 by Torsten Schmits at 2025-12-03T02:34:29+01:00
WIP: unit index
- - - - -
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
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ 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 = unitIndexQuery . hscUnitIndex
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -146,6 +146,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,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
@@ -511,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
@@ -2386,7 +2388,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,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 <- unitIndexQuery (ue_index unit_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 +450,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 +467,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 +482,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
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,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), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +163,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
@@ -194,7 +197,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 =
@@ -205,11 +208,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
@@ -222,13 +225,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
@@ -284,15 +287,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, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1485,8 +1496,9 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger cfg index = do
{-
Plan.
@@ -1542,15 +1554,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1567,7 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
-
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger cfg raw_dbs other_flags
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1576,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 +1750,260 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ IORef UnitIndexBackend ->
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault _ logger cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault ref
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2011,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 +2042,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 +2075,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2150,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e02bbc621ee3fd14a7c57729fb775e3…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e02bbc621ee3fd14a7c57729fb775e3…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
03 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
5b3a9375 by Torsten Schmits at 2025-12-03T01:35:54+01:00
WIP: unit index
- - - - -
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
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ 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 = unitIndexQuery . hscUnitIndex
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -146,6 +146,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,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
@@ -511,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
@@ -2386,7 +2388,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,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 <- unitIndexQuery (ue_index unit_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 +450,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 +467,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 +482,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
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,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), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +163,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
@@ -194,7 +197,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 =
@@ -205,11 +208,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
@@ -222,13 +225,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
@@ -284,15 +287,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, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1485,8 +1496,9 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger cfg index = do
{-
Plan.
@@ -1542,15 +1554,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1567,9 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger cfg raw_dbs other_flags
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ -- pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1578,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 +1752,260 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ ModuleNameProvidersMap,
+ ModuleNameProvidersMap,
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOriginDefault ::
+ UnitIndexBackend ->
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault _ UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault state,
+ index_all = \ s -> s.moduleNameProvidersMap
+ }
+
+updateIndexDefault ::
+ IORef UnitIndexBackend ->
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap, UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault _ logger cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map Semigroup.<> pluginModuleNameProviders
+ pure (mod_map, pluginModuleNameProviders, pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map)
+
+readDatabasesDefault :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault ref
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2013,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 +2044,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 +2077,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2152,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (query.index_all pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (query.index_all unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b3a9375a615885570cbf085646e24d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b3a9375a615885570cbf085646e24d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/torsten.schmits/unit-index-debug] WIP: unit index
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
by Torsten Schmits (＠torsten.schmits) 03 Dec '25
03 Dec '25
Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
Commits:
3a22d87c by Torsten Schmits at 2025-12-03T01:26:24+01:00
WIP: unit index
- - - - -
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
=====================================
@@ -429,6 +429,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -437,7 +438,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -452,6 +453,7 @@ addUnit u = do
(homeUnitId home_unit)
(mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
@@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname
implicit_imports = mkPrelImports modname loc
implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -58,6 +60,7 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndex, UnitIndexQuery, unitIndexQuery)
import GHC.Core ( CoreRule )
import GHC.Core.FamInstEnv
@@ -118,6 +121,12 @@ 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 = unitIndexQuery . hscUnitIndex
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -146,6 +146,7 @@ import GHC.Utils.Constants
import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
import GHC.Types.Unique
import GHC.Iface.Errors.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.Word64Set as W
import GHC.Data.Graph.Directed.Reachability
@@ -188,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
@@ -511,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
@@ -2386,7 +2388,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
let pi_srcimps = rn_imps pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
case eimps of
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -149,7 +149,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -89,6 +89,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
}
@@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; next_wrapper_num <- newIORef emptyModuleEnv
; msg_var <- newIORef emptyMessages
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
bindsToIds (Rec binds) = map fst binds
ids = concatMap bindsToIds binds
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
; runDs hsc_env envs thing_inside
@@ -342,12 +345,12 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
- res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return $ NeedsRecompile recomp
Right es -> do
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -27,6 +27,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage,
) where
@@ -87,6 +88,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery, unitIndexQuery)
import GHC.Data.Bag
import GHC.Data.FastString
@@ -337,7 +339,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 <- unitIndexQuery (ue_index unit_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 +450,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 +467,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 +482,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
=====================================
@@ -13,6 +13,7 @@ import GHC.Data.FastString
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Types.Name
import GHC.Types.Name.Reader
@@ -68,11 +69,11 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state home_unit)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
@@ -206,8 +207,8 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
-mkQualModule unit_state mhome_unit mod
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
| Just home_unit <- mhome_unit
, isHomeModule home_unit mod = False
@@ -218,7 +219,7 @@ mkQualModule unit_state mhome_unit mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -100,6 +100,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
-- | Get home-unit
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -48,6 +48,7 @@ import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
+import GHC.Unit.State (UnitIndexQuery)
import qualified GHC.Data.ShortText as ST
@@ -67,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), hscUnitIndexQuery )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NE
@@ -162,17 +163,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
@@ -194,7 +197,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 =
@@ -205,11 +208,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
@@ -222,13 +225,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
@@ -284,15 +287,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, OverloadedRecordDot, RecordWildCards #-}
-- | Unit manipulation
module GHC.Unit.State (
@@ -49,6 +49,15 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+ unitIndexQuery,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -121,6 +130,8 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import GHC.LanguageExtensions
import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
-- ---------------------------------------------------------------------------
-- The Unit state
@@ -577,10 +588,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> query.findOrigin mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -638,14 +649,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1021,7 +1032,7 @@ selectPackages prec_map arg pkgs unusable
= let matches = matching arg
(ps,rest) = partition matches pkgs
in if null ps
- then Left (filter (matches.fst) (nonDetEltsUniqMap unusable))
+ then Left (filter (matches . fst) (nonDetEltsUniqMap unusable))
else Right (sortByPreference prec_map ps, rest)
-- | Rename a 'UnitInfo' according to some module instantiation.
@@ -1485,8 +1496,9 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger cfg index = do
{-
Plan.
@@ -1542,15 +1554,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> index.readDatabases logger cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1561,159 +1567,9 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
- -- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
-
- -- Now that we've merged everything together, prune out unusable
- -- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
-
- reportCycles logger sccs
- reportUnusable logger unusable
-
- -- Apply trust flags (these flags apply regardless of whether
- -- or not packages are visible or not)
- pkgs1 <- mayThrowUnitErr
- $ foldM (applyTrustFlag prec_map unusable)
- (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
- let prelim_pkg_db = mkUnitInfoMap pkgs1
-
- --
- -- Calculate the initial set of units from package databases, prior to any package flags.
- --
- -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
- -- (not units). This is empty if we have -hide-all-packages.
- --
- -- Then we create an initial visibility map with default visibilities for all
- -- exposed, definite units which belong to the latest valid packages.
- --
- let preferLater unit unit' =
- case compareByPreference prec_map unit unit' of
- GT -> unit
- _ -> unit'
- addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
- -- This is the set of maximally preferable packages. In fact, it is a set of
- -- most preferable *units* keyed by package name, which act as stand-ins in
- -- for "a package in a database". We use units here because we don't have
- -- "a package in a database" as a type currently.
- mostPreferablePackageReps = if unitConfigHideAll cfg
- then emptyUDFM
- else foldl' addIfMorePreferable emptyUDFM pkgs1
- -- When exposing units, we want to consider all of those in the most preferable
- -- packages. We can implement that by looking for units that are equi-preferable
- -- with the most preferable unit for package. Being equi-preferable means that
- -- they must be in the same database, with the same version, and the same package name.
- --
- -- We must take care to consider all these units and not just the most
- -- preferable one, otherwise we can end up with problems like #16228.
- mostPreferable u =
- case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
- Nothing -> False
- Just u' -> compareByPreference prec_map u u' == EQ
- vis_map1 = foldl' (\vm p ->
- -- Note: we NEVER expose indefinite packages by
- -- default, because it's almost assuredly not
- -- what you want (no mix-in linking has occurred).
- if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
- then addToUniqMap vm (mkUnit p)
- UnitVisibility {
- uv_expose_all = True,
- uv_renamings = [],
- uv_package_name = First (Just (fsPackageName p)),
- uv_requirements = emptyUniqMap,
- uv_explicit = Nothing
- }
- else vm)
- emptyUniqMap pkgs1
-
- --
- -- Compute a visibility map according to the command-line flags (-package,
- -- -hide-package). This needs to know about the unusable packages, since if a
- -- user tries to enable an unusable package, we should let them know.
- --
- vis_map2 <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- (unitConfigHideAll cfg) pkgs1)
- vis_map1 other_flags
-
- --
- -- Sort out which packages are wired in. This has to be done last, since
- -- it modifies the unit ids of wired in packages, but when we process
- -- package arguments we need to key against the old versions.
- --
- (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
- let pkg_db = mkUnitInfoMap pkgs2
-
- -- Update the visibility map, so we treat wired packages as visible.
- let vis_map = updateVisibilityMap wired_map vis_map2
-
- let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
- plugin_vis_map <-
- case unitConfigFlagsPlugins cfg of
- -- common case; try to share the old vis_map
- [] | not hide_plugin_pkgs -> return vis_map
- | otherwise -> return emptyUniqMap
- _ -> do let plugin_vis_map1
- | hide_plugin_pkgs = emptyUniqMap
- -- Use the vis_map PRIOR to wired in,
- -- because otherwise applyPackageFlag
- -- won't work.
- | otherwise = vis_map2
- plugin_vis_map2
- <- mayThrowUnitErr
- $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
- hide_plugin_pkgs pkgs1)
- plugin_vis_map1
- (reverse (unitConfigFlagsPlugins cfg))
- -- Updating based on wired in packages is mostly
- -- good hygiene, because it won't matter: no wired in
- -- package has a compiler plugin.
- -- TODO: If a wired in package had a compiler plugin,
- -- and you tried to pick different wired in packages
- -- with the plugin flags and the normal flags... what
- -- would happen? I don't know! But this doesn't seem
- -- likely to actually happen.
- return (updateVisibilityMap wired_map plugin_vis_map2)
-
- let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
- | p <- pkgs2
- ]
- -- The explicitUnits accurately reflects the set of units we have turned
- -- on; as such, it also is the only way one can come up with requirements.
- -- The requirement context is directly based off of this: we simply
- -- look for nested unit IDs that are directly fed holes: the requirements
- -- of those units are precisely the ones we need to track
- let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
- req_ctx = mapUniqMap (Set.toList)
- $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
-
- --
- -- Here we build up a set of the packages mentioned in -package
- -- flags on the command line; these are called the "preload"
- -- packages. we link these packages in eagerly. The preload set
- -- should contain at least rts & base, which is why we pretend that
- -- the command line contains -package rts & -package base.
- --
- -- NB: preload IS important even for type-checking, because we
- -- need the correct include path to be set.
- --
- let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
-
- -- add default preload units if they can be found in the db
- basicLinkedUnits = fmap (RealUnit . Definite)
- $ filter (flip elemUniqMap pkg_db)
- $ unitConfigAutoLink cfg
- preload3 = ordNub $ (basicLinkedUnits ++ preload1)
-
- -- Close the preload packages with their dependencies
- dep_preload <- mayThrowUnitErr
- $ closeUnitDeps pkg_db
- $ zip (map toUnitId preload3) (repeat Nothing)
+ (pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map) <- index.update logger cfg raw_dbs other_flags
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
+ -- pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
-- Force the result to avoid leaking input parameters
let !state = UnitState
@@ -1722,8 +1578,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 = emptyUniqMap
+ , pluginModuleNameProvidersMap = emptyUniqMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1896,6 +1752,260 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ index_all :: ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ query :: IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId],
+ update ::
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (
+ UnitInfoMap,
+ [(Unit, Maybe PackageArg)],
+ [UnitId],
+ UniqMap ModuleName [InstantiatedModule],
+ UniqFM PackageName UnitId,
+ WiringMap
+ )
+ }
+
+unitIndexQuery ::
+ MonadIO m =>
+ UnitIndex ->
+ m UnitIndexQuery
+unitIndexQuery index = liftIO index.query
+
+data UnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders :: !ModuleNameProvidersMap,
+ pluginModuleNameProviders :: !ModuleNameProvidersMap
+ }
+
+newUnitIndexBackend :: UnitIndexBackend
+newUnitIndexBackend =
+ UnitIndexBackend {
+ moduleNameProviders = mempty,
+ pluginModuleNameProviders = mempty
+ }
+
+queryFindOrigin ::
+ UnitIndexBackend ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOrigin UnitIndexBackend {moduleNameProviders} name _plugins =
+ lookupUniqMap moduleNameProviders name
+
+newUnitIndexQuery ::
+ MonadIO m =>
+ IORef UnitIndexBackend ->
+ m UnitIndexQuery
+newUnitIndexQuery ref = do
+ state <- liftIO $ readIORef ref
+ pure UnitIndexQuery {
+ findOrigin = queryFindOrigin state,
+ index_all = state.moduleNameProviders
+ }
+
+updateIndexDefault ::
+ IORef UnitIndexBackend ->
+ Logger ->
+ UnitConfig ->
+ [UnitDatabase UnitId] ->
+ [PackageFlag] ->
+ IO (UnitInfoMap, [(Unit, Maybe PackageArg)], [UnitId], UniqMap ModuleName [InstantiatedModule], UniqFM PackageName UnitId, WiringMap)
+updateIndexDefault ref logger cfg raw_dbs other_flags = do
+
+ -- distrust all units if the flag is set
+ let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
+ dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
+ | otherwise = raw_dbs
+
+
+ -- Merge databases together, without checking validity
+ (pkg_map1, prec_map) <- mergeDatabases logger dbs
+
+ -- Now that we've merged everything together, prune out unusable
+ -- packages.
+ let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+
+ reportCycles logger sccs
+ reportUnusable logger unusable
+
+ -- Apply trust flags (these flags apply regardless of whether
+ -- or not packages are visible or not)
+ pkgs1 <- mayThrowUnitErr
+ $ foldM (applyTrustFlag prec_map unusable)
+ (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
+ let prelim_pkg_db = mkUnitInfoMap pkgs1
+
+ --
+ -- Calculate the initial set of units from package databases, prior to any package flags.
+ --
+ -- Conceptually, we select the latest versions of all valid (not unusable) *packages*
+ -- (not units). This is empty if we have -hide-all-packages.
+ --
+ -- Then we create an initial visibility map with default visibilities for all
+ -- exposed, definite units which belong to the latest valid packages.
+ --
+ let preferLater unit unit' =
+ case compareByPreference prec_map unit unit' of
+ GT -> unit
+ _ -> unit'
+ addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit
+ -- This is the set of maximally preferable packages. In fact, it is a set of
+ -- most preferable *units* keyed by package name, which act as stand-ins in
+ -- for "a package in a database". We use units here because we don't have
+ -- "a package in a database" as a type currently.
+ mostPreferablePackageReps = if unitConfigHideAll cfg
+ then emptyUDFM
+ else foldl' addIfMorePreferable emptyUDFM pkgs1
+ -- When exposing units, we want to consider all of those in the most preferable
+ -- packages. We can implement that by looking for units that are equi-preferable
+ -- with the most preferable unit for package. Being equi-preferable means that
+ -- they must be in the same database, with the same version, and the same package name.
+ --
+ -- We must take care to consider all these units and not just the most
+ -- preferable one, otherwise we can end up with problems like #16228.
+ mostPreferable u =
+ case lookupUDFM mostPreferablePackageReps (fsPackageName u) of
+ Nothing -> False
+ Just u' -> compareByPreference prec_map u u' == EQ
+ vis_map1 = foldl' (\vm p ->
+ -- Note: we NEVER expose indefinite packages by
+ -- default, because it's almost assuredly not
+ -- what you want (no mix-in linking has occurred).
+ if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+ then addToUniqMap vm (mkUnit p)
+ UnitVisibility {
+ uv_expose_all = True,
+ uv_renamings = [],
+ uv_package_name = First (Just (fsPackageName p)),
+ uv_requirements = emptyUniqMap,
+ uv_explicit = Nothing
+ }
+ else vm)
+ emptyUniqMap pkgs1
+
+ --
+ -- Compute a visibility map according to the command-line flags (-package,
+ -- -hide-package). This needs to know about the unusable packages, since if a
+ -- user tries to enable an unusable package, we should let them know.
+ --
+ vis_map2 <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ (unitConfigHideAll cfg) pkgs1)
+ vis_map1 other_flags
+
+ --
+ -- Sort out which packages are wired in. This has to be done last, since
+ -- it modifies the unit ids of wired in packages, but when we process
+ -- package arguments we need to key against the old versions.
+ --
+ (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
+ let pkg_db = mkUnitInfoMap pkgs2
+
+ -- Update the visibility map, so we treat wired packages as visible.
+ let vis_map = updateVisibilityMap wired_map vis_map2
+
+ let hide_plugin_pkgs = unitConfigHideAllPlugins cfg
+ plugin_vis_map <-
+ case unitConfigFlagsPlugins cfg of
+ -- common case; try to share the old vis_map
+ [] | not hide_plugin_pkgs -> return vis_map
+ | otherwise -> return emptyUniqMap
+ _ -> do let plugin_vis_map1
+ | hide_plugin_pkgs = emptyUniqMap
+ -- Use the vis_map PRIOR to wired in,
+ -- because otherwise applyPackageFlag
+ -- won't work.
+ | otherwise = vis_map2
+ plugin_vis_map2
+ <- mayThrowUnitErr
+ $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
+ hide_plugin_pkgs pkgs1)
+ plugin_vis_map1
+ (reverse (unitConfigFlagsPlugins cfg))
+ -- Updating based on wired in packages is mostly
+ -- good hygiene, because it won't matter: no wired in
+ -- package has a compiler plugin.
+ -- TODO: If a wired in package had a compiler plugin,
+ -- and you tried to pick different wired in packages
+ -- with the plugin flags and the normal flags... what
+ -- would happen? I don't know! But this doesn't seem
+ -- likely to actually happen.
+ return (updateVisibilityMap wired_map plugin_vis_map2)
+
+ let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
+ | p <- pkgs2
+ ]
+ -- The explicitUnits accurately reflects the set of units we have turned
+ -- on; as such, it also is the only way one can come up with requirements.
+ -- The requirement context is directly based off of this: we simply
+ -- look for nested unit IDs that are directly fed holes: the requirements
+ -- of those units are precisely the ones we need to track
+ let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map]
+ req_ctx = mapUniqMap (Set.toList)
+ $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
+
+
+ --
+ -- Here we build up a set of the packages mentioned in -package
+ -- flags on the command line; these are called the "preload"
+ -- packages. we link these packages in eagerly. The preload set
+ -- should contain at least rts & base, which is why we pretend that
+ -- the command line contains -package rts & -package base.
+ --
+ -- NB: preload IS important even for type-checking, because we
+ -- need the correct include path to be set.
+ --
+ let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map)
+
+ -- add default preload units if they can be found in the db
+ basicLinkedUnits = fmap (RealUnit . Definite)
+ $ filter (flip elemUniqMap pkg_db)
+ $ unitConfigAutoLink cfg
+ preload3 = ordNub $ (basicLinkedUnits ++ preload1)
+
+ -- Close the preload packages with their dependencies
+ dep_preload <- mayThrowUnitErr
+ $ closeUnitDeps pkg_db
+ $ zip (map toUnitId preload3) (repeat Nothing)
+
+ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map2 = mkUnusableModuleNameProvidersMap unusable
+ mod_map = mod_map2 `plusUniqMap` mod_map1
+ atomicModifyIORef' ref $ \ UnitIndexBackend {..} -> let
+ updated = UnitIndexBackend {
+ moduleNameProviders = moduleNameProviders Semigroup.<> mod_map,
+ pluginModuleNameProviders = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map Semigroup.<> pluginModuleNameProviders,
+ ..
+ }
+ in (updated, (pkg_db, explicit_pkgs, dep_preload, req_ctx, pkgname_map, wired_map))
+
+readDatabasesDefault :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger cfg =
+ readUnitDatabases logger cfg
+
+newUnitIndex :: MonadIO m => m UnitIndex
+newUnitIndex = do
+ ref <- liftIO $ newIORef newUnitIndexBackend
+ pure UnitIndex {
+ query = newUnitIndexQuery ref,
+ readDatabases = readDatabasesDefault,
+ update = updateIndexDefault ref
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1903,10 +2013,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 +2044,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 +2077,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case query.findOrigin m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2033,16 +2152,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList query.index_all
, 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 :: UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames query =
+ map fst (filter visible (nonDetUniqMapToList query.index_all))
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 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 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 :: UnitIndexQuery -> [ModuleName]
+allVisibleModules query = listVisibleModuleNames query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let unit_env = hsc_unit_env hsc_env
ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -844,7 +844,8 @@ initMulti unitArgsFiles = do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ index = hscUnitIndex hsc_env
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure $ HomeUnitEnv
@@ -859,7 +860,7 @@ initMulti unitArgsFiles = do
let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
- let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
+ let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index = hscUnitIndex hsc_env} }
GHC.setSession final_hsc_env
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a22d87c5bd0b97d76facbe7f36001d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a22d87c5bd0b97d76facbe7f36001d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
02 Dec '25
Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC
Commits:
85e0e01f by Adam Gundry at 2025-12-02T21:57:22+00:00
WIP: use CCoercion for CastTy
- - - - -
29 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Coercion.hs-boot
- compiler/GHC/Core/Coercion/Opt.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Reduction.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Type.hs-boot
- compiler/GHC/Core/Unify.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/Unify.hs
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -64,6 +64,8 @@ module GHC.Core.Coercion (
mkForAllCastCo,
mkFunResCastCo,
mkFunCastCoNoFTF,
+ mkGReflLeftCastCo,
+ mkGReflRightCastCo,
applyForAllTy,
decomposeFunCastCo,
@@ -397,7 +399,7 @@ mkSymMCo (MCo co) = MCo (mkSymCo co)
-- | Cast a type by an 'MCoercion'
mkCastTyMCo :: Type -> MCoercion -> Type
mkCastTyMCo ty MRefl = ty
-mkCastTyMCo ty (MCo co) = ty `mkCastTy` co
+mkCastTyMCo ty (MCo co) = ty `mkCastTy` CCoercion co
mkFunResMCo :: Id -> CastCoercion -> CastCoercion
mkFunResMCo _ ReflCastCo = ReflCastCo
@@ -412,6 +414,17 @@ mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion
mkGReflRightMCo r ty MRefl = mkReflCo r ty
mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co
+mkGReflLeftCastCo :: Role -> Type -> CastCoercion -> Coercion
+mkGReflLeftCastCo r ty ReflCastCo = mkReflCo r ty
+mkGReflLeftCastCo r ty (CCoercion co) = mkGReflLeftCo r ty co
+mkGReflLeftCastCo _r _ty (ZCoercion _ki _cos) = error "AMG TODO mkGReflLeftCastCo"
+
+mkGReflRightCastCo :: Role -> Type -> CastCoercion -> Coercion
+mkGReflRightCastCo r ty ReflCastCo = mkReflCo r ty
+mkGReflRightCastCo r ty (CCoercion co) = mkGReflRightCo r ty co
+mkGReflRightCastCo _r _ty (ZCoercion _ki _cos) = error "AMG TODO mkGReflRightCastCo"
+
+
-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'
mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion
mkCoherenceRightMCo _ _ MRefl co2 = co2
@@ -526,7 +539,7 @@ decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args
-- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]
= let arg_co = mkSelCo SelForAll (mkSymCo co)
res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)
- subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)
+ subst1' = extendTCvSubst subst1 a (ty `CastTy` CCoercion arg_co)
subst2' = extendTCvSubst subst2 b ty
in
go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys
@@ -1797,10 +1810,10 @@ castCoercionKind1 :: Coercion -> Role -> Type -> Type
castCoercionKind1 g r t1 t2 h
= case g of
Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal
- mkNomReflCo (mkCastTy t2 h)
+ mkNomReflCo (mkCastTy t2 (CCoercion h))
GRefl _ _ mco -> case mco of
- MRefl -> mkReflCo r (mkCastTy t2 h)
- MCo kind_co -> mkGReflMCo r (mkCastTy t1 h)
+ MRefl -> mkReflCo r (mkCastTy t2 (CCoercion h))
+ MCo kind_co -> mkGReflMCo r (mkCastTy t1 (CCoercion h))
(mkSymCo h `mkTransCo` kind_co `mkTransCo` h)
_ -> castCoercionKind2 g r t1 t2 h h
@@ -2293,8 +2306,10 @@ ty_co_subst !lc role ty
else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)
go r ty@(LitTy {}) = assert (r == Nominal) $
mkNomReflCo ty
- go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co)
+ go r (CastTy ty cco) = castCoercionKind (go r ty) (substLeftCo lc co)
(substRightCo lc co)
+ where
+ co = castCoToCo (typeKind ty) cco
go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co)
(substRightCo lc co)
where kco = go Nominal (coercionType co)
@@ -2617,7 +2632,7 @@ coercion_lr_kind which orig_co
where
go (Refl ty) = ty
go (GRefl _ ty MRefl) = ty
- go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1)
+ go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty (CCoercion co1))
go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos)
go (AppCo co1 co2) = mkAppTy (go co1) (go co2)
go (CoVarCo cv) = go_covar cv
@@ -2710,7 +2725,7 @@ coercion_lr_kind which orig_co
k2 = coercionRKind k_co
tv2 = setTyVarKind tv1 (substTy subst k2)
subst' = extendTvSubst (extendSubstInScope subst tv2) tv1 $
- TyVarTy tv2 `mkCastTy` mkSymCo k_co
+ TyVarTy tv2 `mkCastTy` CCoercion (mkSymCo k_co)
go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR
, fco_kind = k_mco, fco_body = co })
@@ -2815,13 +2830,15 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
| Just ty2' <- coreView ty2 = go ty1 ty2'
- go (CastTy ty1 co) ty2
- = let co' = go ty1 ty2
+ go (CastTy ty1 cco) ty2
+ = let co = castCoToCo (typeKind ty1) cco
+ co' = go ty1 ty2
r = coercionRole co'
in mkCoherenceLeftCo r ty1 co co'
- go ty1 (CastTy ty2 co)
- = let co' = go ty1 ty2
+ go ty1 (CastTy ty2 cco)
+ = let co = castCoToCo (typeKind ty2) cco
+ co' = go ty1 ty2
r = coercionRole co'
in mkCoherenceRightCo r ty2 co co'
@@ -2858,7 +2875,7 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2
where kind_co = go (tyVarKind tv1) (tyVarKind tv2)
in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co
ty2' = substTyWithInScope in_scope [tv2]
- [mkTyVarTy tv1 `mkCastTy` kind_co]
+ [mkTyVarTy tv1 `mkCastTy` CCoercion kind_co]
ty2
go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)
@@ -2972,7 +2989,7 @@ eqCastCoercionX env ty1 co1 ty2 co2 = eqTypeX env ty1 ty2
-- | Convert a 'CastCoercion' back into a 'Coercion', using a 'UnivCo' if we
-- have discarded the original 'Coercion'.
-castCoToCo :: Type -> CastCoercion -> CoercionR
+castCoToCo :: Type -> CastCoercion -> Coercion
castCoToCo _ (CCoercion co) = co
castCoToCo lhs_ty (ZCoercion rhs_ty cos) = mkUnivCo ZCoercionProv (map CoVarCo (nonDetEltsUniqSet cos)) Representational lhs_ty rhs_ty
castCoToCo lhs_ty ReflCastCo = mkRepReflCo lhs_ty
=====================================
compiler/GHC/Core/Coercion.hs-boot
=====================================
@@ -55,3 +55,9 @@ coercionType :: Coercion -> Type
topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
-- used to look through newtypes to the right of
-- function arrows, in 'GHC.Core.Type.getRuntimeArgTys'
+
+castCoToCo :: Type -> CastCoercion -> Coercion
+isReflexiveCastCo :: Type -> CastCoercion -> Bool
+mkTransCastCo :: HasDebugCallStack => CastCoercion -> CastCoercion -> CastCoercion
+seqCastCoercion :: CastCoercion -> ()
+castCoercionRKind :: HasDebugCallStack => Type -> CastCoercion -> Type
=====================================
compiler/GHC/Core/Coercion/Opt.hs
=====================================
@@ -884,7 +884,7 @@ opt_trans_rule is co1 co2
(opt_trans is' r1 r2')
where
is' = is `extendInScopeSet` tv1
- r2' = substCoWithInScope is' [tv2] [mkCastTy (TyVarTy tv1) kco1] r2
+ r2' = substCoWithInScope is' [tv2] [mkCastTyCo (TyVarTy tv1) kco1] r2
-- Push transitivity inside forall
-- forall over coercions.
@@ -1481,7 +1481,7 @@ optForAllCoBndr env sym tcv k_mco
-- override the substitution for the original variable to the
-- re-kinded one, suitably casted
tv2 = tv1 `setTyVarKind` coercionLKind k_co'
- subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` k_co'))
+ subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` CCoercion k_co'))
`extendSubstInScope` tv2
_ -> (subst1, tv1)
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -1485,9 +1485,10 @@ normalise_type ty
; redn <- withLC lc' $ normalise_type ty
; return $ mkForAllRedn vis tv' k_redn redn }
go (TyVarTy tv) = normalise_tyvar tv
- go (CastTy ty co)
+ go (CastTy ty cco)
= do { redn <- go ty
; lc <- getLC
+ ; let co = castCoToCo (typeKind ty) cco
; let co' = substRightCo lc co
; return $ mkCastRedn2 Nominal ty co redn co'
-- ^^^^^^^^^^^ uses castCoercionKind2
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1990,9 +1990,10 @@ lintType ty@(ForAllTy {})
= do { lintType body_ty
; lintForAllBody tcvs body_ty }
-lintType (CastTy ty co)
+lintType (CastTy ty cco)
= do { lintType ty
; ty_kind <- substTyM (typeKind ty)
+ ; let co = castCoToCo (typeKind ty) cco -- TODO: maybe show the actual cco in mkCastTyErr/mkCastErr?
; co_lk <- lintStarCoercion co
; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -2925,7 +2925,7 @@ pushCoTyArg co ty
| isForAllTy_ty tyL
= assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $
- Just (ty `mkCastTy` co1, coercionLKind co2, CCoercion co2)
+ Just (ty `mkCastTyCo` co1, coercionLKind co2, CCoercion co2)
| otherwise
= Nothing
=====================================
compiler/GHC/Core/Reduction.hs
=====================================
@@ -227,7 +227,7 @@ mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction
mkGReflRightRedn role ty co
= mkReduction
(mkGReflRightCo role ty co)
- (mkCastTy ty co)
+ (mkCastTyCo ty co)
{-# INLINE mkGReflRightRedn #-}
-- | Create a 'Reduction' from a kind cast, in which
@@ -236,11 +236,11 @@ mkGReflRightRedn role ty co
-- Given @ty :: k1@, @mco :: k1 ~ k2@,
-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@
-- at the given 'Role'.
-mkGReflRightMRedn :: Role -> Type -> MCoercionN -> Reduction
+mkGReflRightMRedn :: Role -> Type -> CastCoercion -> Reduction
mkGReflRightMRedn role ty mco
= mkReduction
- (mkGReflRightMCo role ty mco)
- (mkCastTyMCo ty mco)
+ (mkGReflRightCastCo role ty mco)
+ (mkCastTy ty mco)
{-# INLINE mkGReflRightMRedn #-}
-- | Create a 'Reduction' from a kind cast, in which
@@ -262,10 +262,10 @@ mkGReflLeftRedn role ty co
-- Given @ty :: k1@, @mco :: k1 ~ k2@,
-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@
-- at the given 'Role'.
-mkGReflLeftMRedn :: Role -> Type -> MCoercionN -> Reduction
+mkGReflLeftMRedn :: Role -> Type -> CastCoercion -> Reduction
mkGReflLeftMRedn role ty mco
= mkReduction
- (mkGReflLeftMCo role ty mco)
+ (mkGReflLeftCastCo role ty mco)
ty
{-# INLINE mkGReflLeftMRedn #-}
@@ -279,7 +279,7 @@ mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction
mkCoherenceRightRedn r (Reduction co1 ty2) kco
= mkReduction
(mkCoherenceRightCo r ty2 kco co1)
- (mkCastTy ty2 kco)
+ (mkCastTyCo ty2 kco)
{-# INLINE mkCoherenceRightRedn #-}
-- | Apply a cast to the result of a 'Reduction', using an 'MCoercionN'.
@@ -314,7 +314,7 @@ mkCastRedn1 r ty cast_co (Reduction co xi)
-- return_co :: (ty |> cast_co) ~r (ty' |> cast_co)
= mkReduction
(castCoercionKind1 co r ty xi cast_co)
- (mkCastTy xi cast_co)
+ (mkCastTyCo xi cast_co)
{-# INLINE mkCastRedn1 #-}
-- | Apply casts on both sides of a 'Reduction' (of the given 'Role').
@@ -333,7 +333,7 @@ mkCastRedn2 :: Role
mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co'
= mkReduction
(castCoercionKind2 nco r ty nty cast_co cast_co')
- (mkCastTy nty cast_co')
+ (mkCastTyCo nty cast_co')
{-# INLINE mkCastRedn2 #-}
-- | Apply one 'Reduction' to another.
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -76,6 +76,7 @@ import GHC.Utils.EndoOS
import GHC.Data.Pair
+import Data.Maybe
import Data.Semigroup
{-
@@ -667,7 +668,7 @@ 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 (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 (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCastCoercion co) f bound_vars acc
tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc
tyCoFVsBndr :: ForAllTyBinder -> FV -> FV
@@ -765,6 +766,11 @@ almost_devoid_co_var_of_mco :: MCoercion -> CoVar -> Bool
almost_devoid_co_var_of_mco MRefl _ = True
almost_devoid_co_var_of_mco (MCo co) cv = almost_devoid_co_var_of_co co cv
+almost_devoid_co_var_of_cast_co :: CastCoercion -> CoVar -> Bool
+almost_devoid_co_var_of_cast_co ReflCastCo _ = True
+almost_devoid_co_var_of_cast_co (CCoercion co) cv = almost_devoid_co_var_of_co co cv
+almost_devoid_co_var_of_cast_co (ZCoercion ty cos) cv = almost_devoid_co_var_of_type ty cv && not (elemVarSet cv cos)
+
almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool
almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and
almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into
@@ -829,7 +835,7 @@ almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv
&& (v == cv || almost_devoid_co_var_of_type ty cv)
almost_devoid_co_var_of_type (CastTy ty co) cv
= almost_devoid_co_var_of_type ty cv
- && almost_devoid_co_var_of_co co cv
+ && almost_devoid_co_var_of_cast_co co cv
almost_devoid_co_var_of_type (CoercionTy co) cv
= almost_devoid_co_var_of_co co cv
@@ -866,7 +872,7 @@ visVarsOfType orig_ty = Pair invis_vars vis_vars
= ((`delVarSet` tv) <$> go ty) `mappend`
(invisible (tyCoVarsOfType $ varType tv))
go (LitTy {}) = mempty
- go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)
+ go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCastCo co)
go (CoercionTy co) = invisible $ tyCoVarsOfCo co
invisible vs = Pair vs emptyVarSet
@@ -1005,7 +1011,7 @@ invisibleVarsOfType = go
where (invisibles, visibles) = partitionInvisibleTypes tc tys
go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty
go LitTy{} = emptyFV
- go (CastTy ty co) = tyCoFVsOfCo co `unionFV` go ty
+ go (CastTy ty co) = tyCoFVsOfCastCoercion co `unionFV` go ty
go (CoercionTy co) = tyCoFVsOfCo co
-- | Like 'invisibleVarsOfType', but for many types.
@@ -1096,7 +1102,7 @@ tyConsOfType ty
go a `unionUniqSets` go b
`unionUniqSets` go_tc (funTyFlagTyCon af)
go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv)
- go (CastTy ty co) = go ty `unionUniqSets` go_co co
+ go (CastTy ty co) = go ty `unionUniqSets` go_cast_co co
go (CoercionTy co) = go_co co
go_co (Refl ty) = go ty
@@ -1123,6 +1129,10 @@ tyConsOfType ty
go_mco MRefl = emptyUniqSet
go_mco (MCo co) = go_co co
+ go_cast_co ReflCastCo = emptyUniqSet
+ go_cast_co (CCoercion co) = go_co co
+ go_cast_co (ZCoercion ty _cos) = go ty
+
go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos
go_tc tc = unitUniqSet tc
@@ -1256,7 +1266,7 @@ occCheckExpand vs_to_avoid ty
-- Failing that, try to expand a synonym
go cxt (CastTy ty co) = do { ty' <- go cxt ty
- ; co' <- go_co cxt co
+ ; co' <- go_cast_co cxt co
; return (CastTy ty' co') }
go cxt (CoercionTy co) = do { co' <- go_co cxt co
; return (CoercionTy co') }
@@ -1273,6 +1283,14 @@ occCheckExpand vs_to_avoid ty
go_mco _ MRefl = return MRefl
go_mco ctx (MCo co) = MCo <$> go_co ctx co
+ go_cast_co _ ReflCastCo = return ReflCastCo
+ go_cast_co ctx (CCoercion co) = CCoercion <$> go_co ctx co
+ go_cast_co ctx (ZCoercion ty cos) = ZCoercion <$> go ctx ty <*> go_covars ctx cos
+
+ go_covars (as, env) cos
+ | anyVarSet (bad_var_occ as) cos = Nothing
+ | otherwise = return $ mapVarSet (\cv -> fromMaybe cv (lookupVarEnv env cv)) cos
+
------------------
go_co cxt (Refl ty) = do { ty' <- go cxt ty
; return (Refl ty') }
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -186,7 +186,7 @@ data Type
| CastTy
Type
- KindCoercion -- ^ A kind cast. The coercion is always nominal.
+ CastCoercion -- ^ A kind cast. The coercion is always nominal.
-- INVARIANT: The cast is never reflexive \(EQ2)
-- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3)
-- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4)
@@ -2055,7 +2055,7 @@ foldTyCo (TyCoFolder { tcf_view = view
go_ty env (TyVarTy tv) = tyvar env tv
go_ty env (AppTy t1 t2) = go_ty env t1 `mappend` go_ty env t2
go_ty _ (LitTy {}) = mempty
- go_ty env (CastTy ty co) = go_ty env ty `mappend` go_co env co
+ go_ty env (CastTy ty co) = go_ty env ty `mappend` go_cast_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 (TyConApp _ tys) = go_tys env tys
@@ -2071,6 +2071,10 @@ foldTyCo (TyCoFolder { tcf_view = view
go_cos _ [] = mempty
go_cos env (c:cs) = go_co env c `mappend` go_cos env cs
+ go_cast_co _ ReflCastCo = mempty
+ go_cast_co env (CCoercion co) = go_co env co
+ go_cast_co env (ZCoercion ty cos) = go_ty env ty `mappend` nonDetStrictFoldVarSet (mappend . covar env) mempty cos
+
go_co env (Refl ty) = go_ty env ty
go_co env (GRefl _ ty MRefl) = go_ty env ty
go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co
@@ -2134,7 +2138,7 @@ typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2
typeSize (FunTy _ _ t1 t2) = typeSize t1 + typeSize t2
typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t
typeSize (TyConApp _ ts) = 1 + typesSize ts
-typeSize (CastTy ty co) = typeSize ty + coercionSize co
+typeSize (CastTy ty co) = typeSize ty + castCoercionSize co
typeSize (CoercionTy co) = coercionSize co
typesSize :: [Type] -> Int
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -797,7 +797,7 @@ subst_ty subst ty
!(subst',tv') = substVarBndrUnchecked subst tv
-- Unchecked because subst_ty is used from substTyUnchecked
go (LitTy n) = LitTy $! n
- go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co)
+ go (CastTy ty co) = (mkCastTy $! (go ty)) $! (substCastCo subst co)
go (CoercionTy co) = CoercionTy $! (subst_co subst co)
substTyVar :: Subst -> TyVar -> Type
=====================================
compiler/GHC/Core/TyCo/Tidy.hs
=====================================
@@ -235,7 +235,7 @@ tidyType env (TyVarTy tv) = TyVarTy $! tidyTyCoVarOcc env tv
tidyType _ t@(TyConApp _ []) = t -- Preserve sharing if possible
tidyType env (TyConApp tycon tys) = TyConApp tycon $! tidyTypes env tys
tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
-tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co)
+tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCastCo env co)
tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co)
tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w
; !arg' = tidyType env arg
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -73,6 +73,7 @@ module GHC.Core.Type (
getLevity, levityType_maybe,
mkCastTy, mkCoercionTy, splitCastTy_maybe,
+ mkCastTyCo,
ErrorMsgType, pprUserTypeErrorTy,
@@ -236,6 +237,7 @@ import GHC.Core.TyCo.FVs
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
+import GHC.Types.Unique.Set
import GHC.Core.TyCon
import GHC.Builtin.Types.Prim
@@ -258,9 +260,12 @@ import {-# SOURCE #-} GHC.Core.Coercion
, mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo
, mkKindCo, mkSubCo, mkFunCo, funRole
, decomposePiCos, coercionKind
- , coercionRKind, coercionType
- , isReflexiveCo, seqCo
+ , coercionType
+ , isReflexiveCastCo, seqCo
, topNormaliseNewType_maybe
+ , mkTransCastCo
+ , seqCastCoercion, castCoercionRKind
+ , castCoToCo
)
import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar )
@@ -514,12 +519,16 @@ expandTypeSynonyms ty
go subst (ForAllTy (Bndr tv vis) t)
= let (subst', tv') = substVarBndrUsing go subst tv in
ForAllTy (Bndr tv' vis) (go subst' t)
- go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co)
+ go subst (CastTy ty co) = mkCastTy (go subst ty) (go_cast_co subst co)
go subst (CoercionTy co) = mkCoercionTy (go_co subst co)
go_mco _ MRefl = MRefl
go_mco subst (MCo co) = MCo (go_co subst co)
+ go_cast_co _ ReflCastCo = ReflCastCo
+ go_cast_co subst (CCoercion co) = CCoercion (go_co subst co)
+ go_cast_co subst (ZCoercion ty cos) = ZCoercion (go subst ty) (substCoVarSet subst cos)
+
go_co subst (Refl ty)
= mkNomReflCo (go subst ty)
go_co subst (GRefl r ty mco)
@@ -905,7 +914,7 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
go_ty !env (TyVarTy tv) = tyvar env tv
go_ty !env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2
go_ty !_ ty@(LitTy {}) = return ty
- go_ty !env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co
+ go_ty !env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_cast_co env co
go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co
go_ty !env ty@(FunTy _ w arg res)
@@ -936,6 +945,10 @@ mapTyCoX (TyCoMapper { tcm_tyvar = tyvar
go_mco !_ MRefl = return MRefl
go_mco !env (MCo co) = MCo <$> (go_co env co)
+ go_cast_co !_ ReflCastCo = return ReflCastCo
+ go_cast_co !env (CCoercion co) = CCoercion <$> (go_co env co)
+ go_cast_co !env (ZCoercion ty cos) = ZCoercion <$> go_ty env ty <*> (coVarsOfCos <$> mapM (covar env) (nonDetEltsUniqSet cos)) -- TODO
+
go_co :: env -> Coercion -> m Coercion
go_co !env (Refl ty) = Refl <$> go_ty env ty
go_co !env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco
@@ -1020,10 +1033,10 @@ isTyVarTy ty = isJust (getTyVar_maybe ty)
-- | If the type is a tyvar, possibly under a cast, returns it, along
-- with the coercion. Thus, the co is :: kind tv ~N kind ty
-getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)
+getCastedTyVar_maybe :: Type -> Maybe (TyVar, CastCoercion)
getCastedTyVar_maybe ty = case coreFullView ty of
CastTy (TyVarTy tv) co -> Just (tv, co)
- TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv))
+ TyVarTy tv -> Just (tv, ReflCastCo)
_ -> Nothing
@@ -1063,9 +1076,10 @@ type checker (e.g. when matching type-function equations).
-- | Applies a type to another, as in e.g. @k a@
mkAppTy :: Type -> Type -> Type
-- See Note [Respecting definitional equality], invariant (EQ1).
-mkAppTy (CastTy fun_ty co) arg_ty
- | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]
- = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co
+mkAppTy (CastTy fun_ty cco) arg_ty
+ | let co = castCoToCo (typeKind fun_ty) cco -- TOOD: can we get rid of this?
+ , ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]
+ = (fun_ty `mkAppTy` (arg_ty `mkCastTy` CCoercion arg_co)) `mkCastTy` CCoercion res_co
mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])
mkAppTy ty1 ty2 = AppTy ty1 ty2
@@ -1084,15 +1098,16 @@ mkAppTy ty1 ty2 = AppTy ty1 ty2
mkAppTys :: Type -> [Type] -> Type
mkAppTys ty1 [] = ty1
-mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy
+mkAppTys (CastTy fun_ty cco) arg_tys -- much more efficient then nested mkAppTy
-- Why do this? See (EQ1) of
-- Note [Respecting definitional equality]
-- in GHC.Core.TyCo.Rep
- = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers
+ = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` CCoercion res_co) leftovers
where
+ co = castCoToCo (typeKind fun_ty) cco
(arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys
(args_to_cast, leftovers) = splitAtList arg_cos arg_tys
- casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos
+ casted_arg_tys = zipWith (\ ty co -> mkCastTy ty (CCoercion co)) args_to_cast arg_cos
mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)
mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2
@@ -1647,16 +1662,19 @@ newTyConInstRhs tycon tys
* *
********************************************************************* -}
-splitCastTy_maybe :: Type -> Maybe (Type, Coercion)
+splitCastTy_maybe :: Type -> Maybe (Type, CastCoercion)
splitCastTy_maybe ty
| CastTy ty' co <- coreFullView ty = Just (ty', co)
| otherwise = Nothing
+mkCastTyCo :: Type -> Coercion -> Type
+mkCastTyCo ty co = mkCastTy ty (CCoercion co)
+
-- | Make a 'CastTy'. The Coercion must be nominal. Checks the
-- Coercion for reflexivity, dropping it if it's reflexive.
-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep"
-mkCastTy :: Type -> Coercion -> Type
-mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note
+mkCastTy :: Type -> CastCoercion -> Type
+mkCastTy orig_ty co | isReflexiveCastCo (typeKind orig_ty) co = orig_ty -- (EQ2) from the Note
-- NB: Do the slow check here. This is important to keep the splitXXX
-- functions working properly. Otherwise, we may end up with something
-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)
@@ -1666,7 +1684,7 @@ mkCastTy orig_ty co = mk_cast_ty orig_ty co
-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity,
-- as that can be expensive.
-mk_cast_ty :: Type -> Coercion -> Type
+mk_cast_ty :: Type -> CastCoercion -> Type
mk_cast_ty orig_ty co = go orig_ty
where
go :: Type -> Type
@@ -1675,14 +1693,14 @@ mk_cast_ty orig_ty co = go orig_ty
go (CastTy ty co1)
-- (EQ3) from the Note
- = mkCastTy ty (co1 `mkTransCo` co)
+ = mkCastTy ty (co1 `mkTransCastCo` co)
-- call mkCastTy again for the reflexivity check
go (ForAllTy (Bndr tv vis) inner_ty)
-- (EQ4) from the Note
-- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep.
| isTyVar tv
- , let fvs = tyCoVarsOfCo co
+ , let fvs = tyCoVarsOfCastCo co
= -- have to make sure that pushing the co in doesn't capture the bound var!
if tv `elemVarSet` fvs
then let empty_subst = mkEmptySubst (mkInScopeSet fvs)
@@ -2546,7 +2564,7 @@ seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty
-seqType (CastTy ty co) = seqType ty `seq` seqCo co
+seqType (CastTy ty co) = seqType ty `seq` seqCastCoercion co
seqType (CoercionTy co) = seqCo co
seqTypes :: [Type] -> ()
@@ -2640,7 +2658,7 @@ typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys
typeKind (LitTy l) = typeLiteralKind l
typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af)
typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (CastTy _ty co) = coercionRKind co
+typeKind (CastTy ty co) = castCoercionRKind (typeKind ty) co
typeKind (CoercionTy co) = coercionType co
typeKind (AppTy fun arg)
=====================================
compiler/GHC/Core/Type.hs-boot
=====================================
@@ -4,7 +4,7 @@ module GHC.Core.Type where
import GHC.Prelude
import {-# SOURCE #-} GHC.Core.TyCon
-import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion )
+import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, CastCoercion )
import GHC.Utils.Misc
import GHC.Types.Var( FunTyFlag, TyVar )
import GHC.Types.Basic( TypeOrConstraint )
@@ -16,7 +16,7 @@ chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag
typeKind :: HasDebugCallStack => Type -> Type
isCoercionTy :: Type -> Bool
mkAppTy :: Type -> Type -> Type
-mkCastTy :: Type -> Coercion -> Type
+mkCastTy :: Type -> CastCoercion -> Type
mkTyConApp :: TyCon -> [Type] -> Type
getLevity :: HasDebugCallStack => Type -> Type
getTyVar_maybe :: Type -> Maybe TyVar
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1582,12 +1582,13 @@ type AmIUnifying = Bool -- True <=> Unifying
-- False <=> Matching
type InType = Type -- Before applying the RnEnv2
-type OutCoercion = Coercion -- After applying the RnEnv2
+type OutCastCoercion = CastCoercion -- After applying the RnEnv2
+
unify_ty :: UMEnv
-> InType -> InType -- Types to be unified
- -> OutCoercion -- A nominal coercion between their kinds
+ -> OutCastCoercion -- A nominal coercion between their kinds
-- OutCoercion: the RnEnv has already been applied
-- When matching, the coercion is in "target space",
-- not "template space"
@@ -1609,28 +1610,28 @@ unify_ty env ty1 ty2 kco
| Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco
unify_ty env (CastTy ty1 co1) ty2 kco
- | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1)
+ | mentionsForAllBoundTyVarsL env (tyCoVarsOfCastCo co1)
-- See (KCU1) in Note [Kind coercions in Unify]
= maybeApart MARCast -- See (KCU2)
| um_unif env
- = unify_ty env ty1 ty2 (co1 `mkTransCo` kco)
+ = unify_ty env ty1 ty2 (co1 `mkTransCastCo` kco)
| otherwise -- We are matching, not unifying
= do { subst <- getSubst env
- ; let co' = substCo subst co1
+ ; let co' = substCastCo subst co1
-- We match left-to-right, so the free template vars of the
-- coercion should already have been matched.
-- See Note [Matching in the presence of casts (1)]
-- NB: co1 does not mention forall-bound vars, so no need to rename
- ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) }
+ ; unify_ty env ty1 ty2 (co' `mkTransCastCo` kco) }
unify_ty env ty1 (CastTy ty2 co2) kco
- | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)
+ | mentionsForAllBoundTyVarsR env (tyCoVarsOfCastCo co2)
-- See (KCU1) in Note [Kind coercions in Unify]
= maybeApart MARCast -- See (KCU2)
| otherwise
- = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2)
+ = unify_ty env ty1 ty2 (kco `mkTransCastCo` mkSymCastCo (typeKind ty2) co2)
-- NB: co2 does not mention forall-bound variables
-- Applications need a bit of care!
@@ -1647,7 +1648,7 @@ unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()
unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco
-- ToDo: See Note [Unifying coercion-foralls]
- = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)
+ = do { unify_ty env (varType tv1) (varType tv2) ReflCastCo
; let env' = umRnBndr2 env tv1 tv2
; unify_ty env' ty1 ty2 kco }
@@ -1658,7 +1659,7 @@ unify_ty env (CoercionTy co1) (CoercionTy co2) kco
CoVarCo cv
| not (um_unif env)
, not (cv `elemVarEnv` c_subst) -- Not forall-bound
- , let (_mult_co, co_l, co_r) = decomposeFunCo kco
+ , let (_mult_co, co_l, co_r) = decomposeFunCo (castCoToCo (typeKind (CoercionTy co1)) kco)
-- Because the coercion is used in a type, it should be safe to
-- ignore the multiplicity coercion, _mult_co
-- cv :: t1 ~ t2
@@ -1678,7 +1679,7 @@ unify_ty env (TyVarTy tv1) ty2 kco
unify_ty env ty1 (TyVarTy tv2) kco
| um_unif env -- If unifying, can swap args; but not when matching
- = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco)
+ = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCastCo (typeKind ty1) kco)
-- Deal with TyConApps
unify_ty env ty1 ty2 kco
@@ -1689,7 +1690,7 @@ unify_ty env ty1 ty2 kco
| um_unif env
, Just (tc,tys) <- mb_sat_fam_app2
- = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco)
+ = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCastCo (typeKind ty1) kco)
-- Handle oversaturated type families. Suppose we have
-- (F a b) ~ (c d) where F has arity 1
@@ -1760,8 +1761,8 @@ unify_ty_app env ty1 ty1args ty2 ty2args
= do { let ki1 = typeKind ty1
ki2 = typeKind ty2
-- See Note [Kind coercions in Unify]
- ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind)
- ; unify_ty env ty1 ty2 (mkNomReflCo ki2)
+ ; unify_ty env ki1 ki2 ReflCastCo
+ ; unify_ty env ty1 ty2 ReflCastCo -- TODO: simplify following comment?
-- Very important: 'ki2' not 'ki1'
-- See Note [Matching in the presence of casts (2)]
; unify_tys env ty1args ty2args }
@@ -1775,7 +1776,7 @@ unify_tys env orig_xs orig_ys
go [] [] = return ()
go (x:xs) (y:ys)
-- See Note [Kind coercions in Unify]
- = do { unify_ty env x y (mkNomReflCo $ typeKind y)
+ = do { unify_ty env x y ReflCastCo -- TODO: simplify following comment?
-- Very important: 'y' not 'x'
-- See Note [Matching in the presence of casts (2)]
; go xs ys }
@@ -1784,7 +1785,7 @@ unify_tys env orig_xs orig_ys
-- See Note [Polykinded tycon applications]
---------------------------------
-uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()
+uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCastCoercion -> UM ()
-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy
-- (b) both args have had coreView already applied
-- Why saturated? See (ATF4) in Note [Apartness and type families]
@@ -1811,7 +1812,7 @@ uVarOrFam env ty1 ty2 kco
-----------------------------
-- LHS is a type variable
-- The sequence of tests is very similar to go_tv
- go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM ()
+ go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCastCoercion -> UM ()
go swapped substs lhs@(TyVarLHS tv1) ty2 kco
| Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'
= -- We already have a substitution for tv1
@@ -1856,7 +1857,7 @@ uVarOrFam env ty1 ty2 kco
| um_unif env
, NotSwapped <- swapped -- If we have swapped already, don't do so again
, Just lhs2 <- canEqLHS_maybe ty2
- = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco)
+ = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCastCo (varType tv1) kco)
| occurs_check = maybeApart MARInfinite -- Occurs check
| otherwise = surelyApart
@@ -1864,7 +1865,7 @@ uVarOrFam env ty1 ty2 kco
where
tv1' = umRnOccL env tv1
ty2_fvs = tyCoVarsOfType ty2
- rhs = ty2 `mkCastTy` mkSymCo kco
+ rhs = ty2 `mkCastTy` mkSymCastCo (varType tv1') kco
tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs)
-- tv1' is not forall-bound, but tv1 can still differ
-- from tv1; see Note [Cloning the template binders]
@@ -1928,13 +1929,14 @@ uVarOrFam env ty1 ty2 kco
| um_unif env
, NotSwapped <- swapped
, Just lhs2 <- canEqLHS_maybe ty2
- = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco)
+ , let ty1' = mkTyConApp tc1 tys1
+ = go IsSwapped substs lhs2 ty1' (mkSymCastCo (typeKind ty1') kco)
| otherwise -- See (ATF5) in Note [Apartness and type families]
= surelyApart
where
- rhs = ty2 `mkCastTy` mkSymCo kco
+ rhs = ty2 `mkCastTy` mkSymCastCo (typeKind (mkTyConApp tc1 tys1)) kco
-----------------------------
-- go_fam_fam: LHS and RHS are both saturated type-family applications,
@@ -1971,7 +1973,7 @@ uVarOrFam env ty1 ty2 kco
| otherwise
= return ()
- rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco
+ rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCastCo (typeKind (mkTyConApp tc tys1)) kco -- TODO: correct?
rhs2 = mkTyConApp tc tys1 `mkCastTy` kco
@@ -2335,9 +2337,10 @@ ty_co_match menv subst ty co lkco rkco
noneSet f = allVarSet (not . f)
ty_co_match menv subst ty co lkco rkco
- | CastTy ty' co' <- ty
+ | CastTy ty' cco' <- ty
-- See Note [Matching in the presence of casts (1)]
= let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv))
+ co' = castCoToCo (typeKind ty') cco'
substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co'
substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'
in
@@ -2448,7 +2451,7 @@ ty_co_match menv subst ty co1 lkco rkco
-- But transitive coercions are not helpful. Therefore we deal
-- with it here: we do recursion on the smaller reflexive coercion,
-- while propagating the correct kind coercions.
- = let kco' = mkSymCo co
+ = let kco' = mkSymCo (castCoToCo (typeKind t) co)
in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')
(rkco `mkTransCo` kco')
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -192,7 +192,7 @@ toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
(toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af })
= IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
-toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)
+toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCastCoercionX fr co)
toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)
toIfaceTypeX fr (TyConApp tc tys)
@@ -271,9 +271,12 @@ toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x
----------------
toIfaceCastCoercion :: CastCoercion -> IfaceCastCoercion
-toIfaceCastCoercion (CCoercion co) = IfaceCCoercion (toIfaceCoercion co)
-toIfaceCastCoercion (ZCoercion ty cos) = IfaceZCoercion (toIfaceType ty) (map (toIfaceCoercion . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO determinism
-toIfaceCastCoercion ReflCastCo = IfaceReflCastCo
+toIfaceCastCoercion = toIfaceCastCoercionX emptyVarSet
+
+toIfaceCastCoercionX :: VarSet -> CastCoercion -> IfaceCastCoercion
+toIfaceCastCoercionX fr (CCoercion co) = IfaceCCoercion (toIfaceCoercionX fr co)
+toIfaceCastCoercionX fr (ZCoercion ty cos) = IfaceZCoercion (toIfaceTypeX fr ty) (map (toIfaceCoercionX fr . CoVarCo) (nonDetEltsUniqSet cos)) -- TODO determinism
+toIfaceCastCoercionX _ ReflCastCo = IfaceReflCastCo
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion = toIfaceCoercionX emptyVarSet
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -748,7 +748,7 @@ mkUnsafeCoercePrimPair _old_id old_expr
runtimeRep1Ty
runtimeRep2Ty
(scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)
- (openAlphaTy `mkCastTy` alpha_co)
+ (openAlphaTy `mkCastTyCo` alpha_co)
openBetaTy
-- alpha_co :: TYPE r1 ~# TYPE r2
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -947,7 +947,7 @@ rnIfaceType (IfaceForAllTy tv t)
rnIfaceType (IfaceCoercionTy co)
= IfaceCoercionTy <$> rnIfaceCo co
rnIfaceType (IfaceCastTy ty co)
- = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+ = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCastCo co
rnIfaceScaledType :: Rename (IfaceMult, IfaceType)
rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -2067,7 +2067,7 @@ freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy _ w s t) = freeNamesIfType s &&& freeNamesIfType t &&& freeNamesIfType w
-freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
+freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCastCoercion c
freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
freeNamesIfMCoercion :: IfaceMCoercion -> NameSet
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -190,7 +190,7 @@ data IfaceType
| IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
- | IfaceCastTy IfaceType IfaceCoercion
+ | IfaceCastTy IfaceType IfaceCastCoercion
| IfaceCoercionTy IfaceCoercion
| IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
@@ -776,12 +776,16 @@ substIfaceType env ty
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys)
go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
- go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
+ go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_cast_co co)
go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
go_mco IfaceMRefl = IfaceMRefl
go_mco (IfaceMCo co) = IfaceMCo $ go_co co
+ go_cast_co IfaceReflCastCo = IfaceReflCastCo
+ go_cast_co (IfaceCCoercion co) = IfaceCCoercion (go_co co)
+ go_cast_co (IfaceZCoercion ty cos) = IfaceZCoercion (go ty) (map go_co cos)
+
go_co (IfaceReflCo ty) = IfaceReflCo (go ty)
go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco)
go_co (IfaceFunCo r w c1 c2) = IfaceFunCo r (go_co w) (go_co c1) (go_co c2)
@@ -2191,6 +2195,9 @@ pprPromotionQuoteI IsPromoted = char '\''
instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
+instance Outputable IfaceCastCoercion where
+ ppr = pprIfaceCastCoercion
+
instance Binary IfaceTyCon where
put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1527,7 +1527,7 @@ tcIfaceType = go
go (IfaceForAllTy bndr t)
= bindIfaceForAllBndr bndr $ \ tv' vis ->
ForAllTy (Bndr tv' vis) <$> go t
- go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
+ go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCastCoercion co
go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -813,7 +813,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args
-- NB: kappa is uninstantiated ('go' already checked that)
; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)
-- unifyKind: see (UQL3) in Note [QuickLook unification]
- ; liftZonkM (writeMetaTyVar kappa (mkCastTy fun_ty' kind_co))
+ ; liftZonkM (writeMetaTyVar kappa (mkCastTyCo fun_ty' kind_co))
; let co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co)
acc' = addArgWrap co_wrap acc
@@ -2225,7 +2225,7 @@ qlUnify ty1 ty2
do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
-- unifyKind: see (UQL2) in Note [QuickLook unification]
-- and (MIV2) in Note [Monomorphise instantiation variables]
- ; let ty2' = mkCastTy ty2 co
+ ; let ty2' = mkCastTyCo ty2 co
; traceTc "qlUnify:update" $
ppr kappa <+> text ":=" <+> ppr ty2
; liftZonkM $ writeMetaTyVar kappa ty2' }
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
-import GHC.Core.Coercion( mkSymCo )
+import GHC.Core.Coercion( mkSymCastCo )
import GHC.Core.Type (mkStrLitTy, mkCastTy)
import GHC.Core.TyCo.Ppr( pprTyVars )
import GHC.Core.TyCo.Tidy( tidyOpenTypeX )
@@ -1093,7 +1093,7 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- So, to make the kinds work out, we reverse the cast here.
Just (wc_var, wc_co) -> liftZonkM $
writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta
- `mkCastTy` mkSymCo wc_co)
+ `mkCastTy` mkSymCastCo (varType wc_var) wc_co)
Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
; traceTc "completeTheta" $
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1696,7 +1696,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
do { let arrows_needed = n_initial_val_args all_args
; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki
- ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co)
+ ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTyCo` co)
-- This zonk is essential, to expose the fruits
-- of matchExpectedFunKind to the 'go' loop
@@ -1963,7 +1963,7 @@ checkExpectedKind hs_ty ty act_kind exp_kind
; traceTc "checkExpectedKind" (vcat [ ppr act_kind
, ppr exp_kind
, ppr co_k ])
- ; return (res_ty `mkCastTy` co_k) } }
+ ; return (res_ty `mkCastTyCo` co_k) } }
where
-- We need to make sure that both kinds have the same number of implicit
-- foralls and constraints out front. If the actual kind has more, instantiate
@@ -1986,7 +1986,7 @@ checkExpKind _rn_ty ty ki (Infer cell) = do
-- NB: do not instantiate.
-- See Note [Do not always instantiate eagerly in types]
co <- fillInferResultNoInst ki cell
- pure (ty `mkCastTy` co)
+ pure (ty `mkCastTyCo` co)
---------------------------
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -359,11 +359,11 @@ can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
| isNothing (canEqLHS_maybe ty2)
= -- See (EIK3) in Note [Equalities with heterogeneous kinds]
- canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
+ canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 (castCoToCo (typeKind ty1) co1) ty2 ps_ty2
can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
| isNothing (canEqLHS_maybe ty1)
= -- See (EIK3) in Note [Equalities with heterogeneous kinds]
- canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
+ canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 (castCoToCo (typeKind ty2) co2) ty1 ps_ty1
----------------------
-- Otherwise try to decompose
@@ -522,7 +522,7 @@ can_eq_nc_forall ev eq_rel s1 s2
(substTy subst2 (tyVarKind tv2))
; let subst2' = extendTvSubstAndInScope subst2 tv2
- (mkCastTy (mkTyVarTy skol_tv) kind_co)
+ (mkCastTyCo (mkTyVarTy skol_tv) kind_co)
-- skol_tv is already in the in-scope set, but the
-- free vars of kind_co are not; hence "...AndInScope"
; co <- go uenv skol_tvs subst2' bndrs1 bndrs2
@@ -1741,7 +1741,7 @@ canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2
-- kind_co :: ki2 ~N ki1
lhs_redn = mkReflRedn role ps_xi1
rhs_redn = mkGReflRightRedn role xi2 kind_co
- new_xi2 = mkCastTy ps_xi2 kind_co
+ new_xi2 = mkCastTyCo ps_xi2 kind_co
canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs
-- or, if swapped: rhs ~ lhs
@@ -1753,14 +1753,14 @@ canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs
canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
| (xi2', mco) <- split_cast_ty xi2
, Just lhs2 <- canEqLHS_maybe xi2'
- = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco
+ = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTy` mkSymCastCo (typeKind xi2') mco) mco
| otherwise
= canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
where
- split_cast_ty (CastTy ty co) = (ty, MCo co)
- split_cast_ty other = (other, MRefl)
+ split_cast_ty (CastTy ty co) = (ty, co)
+ split_cast_ty other = (other, ReflCastCo)
-- This function deals with the case that both LHS and RHS are potential
-- CanEqLHSs.
@@ -1771,7 +1771,7 @@ canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco)
-> TcType -- pretty lhs
-> CanEqLHS -- rhs
-> TcType -- pretty rhs
- -> MCoercion -- :: kind(rhs) ~N kind(lhs)
+ -> CastCoercion -- :: kind(rhs) ~N kind(lhs)
-> TcS (StopOrContinue (Either IrredCt EqCt))
canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
| lhs1 `eqCanEqLHS` lhs2
@@ -1823,13 +1823,13 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
then finish_with_swapping
else finish_without_swapping }
where
- sym_mco = mkSymMCo mco
+ sym_mco = mkSymCastCo (canEqLHSKind lhs2) mco
role = eqRelRole eq_rel
lhs1_ty = canEqLHSType lhs1
lhs2_ty = canEqLHSType lhs2
finish_without_swapping
- = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)
+ = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTy` mco)
-- Swapping. We have ev : lhs1 ~ lhs2 |> co
-- We swap to new_ev : lhs2 ~ lhs1 |> sym co
@@ -1840,7 +1840,7 @@ canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
= do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco
lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco
; new_ev <-rewriteEqEvidence ev swapped lhs1_redn lhs2_redn emptyCoHoleSet
- ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
+ ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTy` sym_mco) }
put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq
-- See Note [Orienting TyVarLHS/TyFamLHS]
=====================================
compiler/GHC/Tc/Solver/Rewrite.hs
=====================================
@@ -561,8 +561,9 @@ rewrite_one ty@(ForAllTy {})
; redn <- rewrite_one rho
; return $ mkHomoForAllRedn bndrs redn }
-rewrite_one (CastTy ty g)
+rewrite_one (CastTy ty cco)
= do { redn <- rewrite_one ty
+ ; let g = castCoToCo (typeKind ty) cco
; g' <- rewrite_co g
; role <- getRole
; return $ mkCastRedn1 role ty g' redn }
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Hs
-import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..) )
+import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), CastCoercion(..) )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Make( rEC_SEL_ERROR_ID )
@@ -101,7 +101,7 @@ synonymTyConsOfType ty
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy _ w a b) = go w `plusNameEnv` go a `plusNameEnv` go b
go (ForAllTy _ ty) = go ty
- go (CastTy ty co) = go ty `plusNameEnv` go_co co
+ go (CastTy ty co) = go ty `plusNameEnv` go_cast_co co
go (CoercionTy co) = go_co co
-- Note [TyCon cycles through coercions?!]
@@ -128,6 +128,10 @@ synonymTyConsOfType ty
go_mco MRefl = emptyNameEnv
go_mco (MCo co) = go_co co
+ go_cast_co ReflCastCo = emptyNameEnv
+ go_cast_co (CCoercion co) = go_co co
+ go_cast_co (ZCoercion ty _) = go ty
+
go_co (Refl ty) = go ty
go_co (GRefl _ ty mco) = go ty `plusNameEnv` go_mco mco
go_co (TyConAppCo _ tc cs) = go_tc tc `plusNameEnv` go_co_s cs
=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -331,7 +331,7 @@ instTyVarsWith orig tvs tys
= go (extendTvSubstAndInScope subst tv ty) tvs tys
| otherwise
= do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
- ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }
+ ; go (extendTvSubstAndInScope subst tv (ty `mkCastTyCo` co)) tvs tys }
where
tv_kind = substTy subst (tyVarKind tv)
ty_kind = typeKind ty
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -1435,7 +1435,7 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
go dv (FunTy _ w arg res) = foldlM go dv [w, arg, 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 }
+ ; collect_cand_qtvs_cast_co orig_ty cur_lvl bound dv1 co }
go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty cur_lvl bound dv co
go dv (TyVarTy tv)
@@ -1516,6 +1516,18 @@ collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty
-- See Note [Recurring into kinds for candidateQTyVars]
; collect_cand_qtvs orig_ty True cur_lvl bound dv' tv_kind } }
+collect_cand_qtvs_cast_co :: TcType -- original type at top of recursion; for errors
+ -> TcLevel
+ -> VarSet -- bound variables
+ -> CandidatesQTvs -> CastCoercion
+ -> TcM CandidatesQTvs
+collect_cand_qtvs_cast_co orig_ty cur_lvl bound dv cco = case cco of
+ ReflCastCo -> return dv
+ CCoercion co -> collect_cand_qtvs_co orig_ty cur_lvl bound dv co
+ ZCoercion ty cos -> do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty
+ ; foldM (\dv cv -> collect_cand_qtvs_co orig_ty cur_lvl bound dv (CoVarCo cv)) dv1 (nonDetEltsUniqSet cos) -- TODO
+ }
+
collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors
-> TcLevel
-> VarSet -- bound variables
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -2696,11 +2696,11 @@ uType env@(UE { u_role = role }) orig_ty1 orig_ty2
-- didn't do it this way, and then the unification above was deferred.
go (CastTy t1 co1) t2
= do { co_tys <- uType env t1 t2
- ; return (mkCoherenceLeftCo role t1 co1 co_tys) }
+ ; return (mkCoherenceLeftCo role t1 (castCoToCo (typeKind t1) co1) co_tys) }
go t1 (CastTy t2 co2)
= do { co_tys <- uType env t1 t2
- ; return (mkCoherenceRightCo role t2 co2 co_tys) }
+ ; return (mkCoherenceRightCo role t2 (castCoToCo (typeKind t2) co2) co_tys) }
-- Variables; go for uUnfilledVar
-- Note that we pass in *original* (before synonym expansion),
@@ -3484,7 +3484,7 @@ simpleUnifyCheck caller given_eq_lvl lhs_tv rhs
where
lhs_info = metaTyVarInfo lhs_tv
- !(occ_in_ty, occ_in_co) = mkOccFolders (tyVarName lhs_tv)
+ !(occ_in_ty, occ_in_co, occ_in_cast_co) = mkOccFolders (tyVarName lhs_tv)
lhs_tv_lvl = tcTyVarLevel lhs_tv
lhs_tv_is_concrete = isConcreteTyVar lhs_tv
@@ -3525,17 +3525,17 @@ simpleUnifyCheck caller given_eq_lvl lhs_tv rhs
| otherwise = False
rhs_is_ok (AppTy t1 t2) = rhs_is_ok t1 && rhs_is_ok t2
- rhs_is_ok (CastTy ty co) = not (occ_in_co co) && rhs_is_ok ty
+ rhs_is_ok (CastTy ty co) = not (occ_in_cast_co co) && rhs_is_ok ty
rhs_is_ok (CoercionTy co) = not (occ_in_co co)
rhs_is_ok (LitTy {}) = True
-mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool)
+mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool, TcCastCoercion -> Bool)
-- These functions return True
-- * if lhs_tv occurs (incl deeply, in the kind of variable)
-- * if there is a coercion hole
-- No expansion of type synonyms
-mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)
+mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co, getAny . check_cast_co)
where
!(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet
occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms
@@ -3549,6 +3549,11 @@ mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co)
do_bndr is tcv _faf = extendVarSet is tcv
do_hole _is _hole = DM.Any True -- Reject coercion holes
+ check_cast_co ReflCastCo = Any False
+ check_cast_co (CCoercion co) = check_co co
+ check_cast_co (ZCoercion _ty _cos) = error "AMG TODO check_cast_co"
+
+
{- *********************************************************************
* *
Equality invariant checking
@@ -4144,7 +4149,7 @@ check_ty_eq_rhs flags ty
; return (mkAppRedn <$> fun_res <*> arg_res) }
CastTy ty co -> do { ty_res <- check_ty_eq_rhs flags ty
- ; co_res <- checkCo flags co
+ ; co_res <- checkCo flags (castCoToCo (typeKind ty) co)
; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }
CoercionTy co -> do { co_res <- checkCo flags co
@@ -4540,7 +4545,7 @@ simpleOccursCheck (OC_Check lhs_tv occ_prob) occ_tv
| otherwise
= TyVarCheck_Success
where
- (check_kind, _) = mkOccFolders lhs_tv
+ (check_kind, _, _) = mkOccFolders lhs_tv
-------------------------
tyVarLevelCheck :: LevelCheck m -> TcTyVar -> TyVarCheckResult m
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85e0e01f31532219cb8f4a808b84d5a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85e0e01f31532219cb8f4a808b84d5a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/spj-apporv-Oct24] in QuicklookArg, wrap the inferAppHead_maybe with an optional error context...
by Apoorv Ingle (＠ani) 02 Dec '25
by Apoorv Ingle (＠ani) 02 Dec '25
02 Dec '25
Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC
Commits:
929a03d5 by Apoorv Ingle at 2025-12-02T15:32:25-06:00
in QuicklookArg, wrap the inferAppHead_maybe with an optional error context update. If the head is a XExpr, we need to flip the state to generated
- - - - -
1 changed file:
- compiler/GHC/Tc/Gen/App.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -1959,7 +1959,8 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
| otherwise = fun_lspan_arg'
-- Step 1: get the type of the head of the argument
- ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg
+ ; (fun_ue, mb_fun_ty) <- maybe_update_err_ctxt fun_lspan_arg rn_fun_arg $
+ (tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg)
-- tcCollectingUsage: the use of an Id at the head generates usage-info
-- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must
-- capture and save it in the `EValArgQL`. See (QLA6) in
@@ -2027,6 +2028,17 @@ quickLookArg1 pos app_lspan (fun, fun_lspan) larg@(L arg_loc arg) sc_arg_ty@(Sca
, eaql_encl = arg_influences_enclosing_call
, eaql_res_rho = app_res_rho }) }}}
+
+maybe_update_err_ctxt :: SrcSpan -> HsExpr GhcRn -> TcM a -> TcM a
+maybe_update_err_ctxt fun_lspan_arg rn_fun_arg thing_inside
+ | not (isGeneratedSrcSpan fun_lspan_arg)
+ , XExpr (ExpandedThingRn{}) <- rn_fun_arg
+ = addLExprCtxt fun_lspan_arg rn_fun_arg $ thing_inside
+ | otherwise
+ = thing_inside
+
+
+
mk_origin :: SrcSpan -- SrcSpan of the argument
-> HsExpr GhcRn -- The head of the expression application chain
-> HsExpr GhcRn -- Fallback expression to appear in the error message
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/929a03d58f6a7c07341dde47ecd6293…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/929a03d58f6a7c07341dde47ecd6293…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/unit-index-debug
by Torsten Schmits (＠torsten.schmits) 02 Dec '25
by Torsten Schmits (＠torsten.schmits) 02 Dec '25
02 Dec '25
Torsten Schmits pushed new branch wip/torsten.schmits/unit-index-debug at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/unit-index-de…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fix-25636] Converting naming to NullaryClosure
by recursion-ninja (＠recursion-ninja) 02 Dec '25
by recursion-ninja (＠recursion-ninja) 02 Dec '25
02 Dec '25
recursion-ninja pushed to branch wip/fix-25636 at Glasgow Haskell Compiler / GHC
Commits:
3022392c by Recursion Ninja at 2025-12-02T13:09:14-05:00
Converting naming to NullaryClosure
- - - - -
14 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghci/GHCi/CreateBCO.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/ResolvedBCO.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/ghci.cabal.in
- rts/PrimOps.cmm
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3937,9 +3937,9 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
with
out_of_line = True
-primop NewUDCOp "newUDC#" GenPrimOp
+primop NewNullaryClosureOp "newNullaryClosure#" GenPrimOp
Addr# -> State# s -> (# State# s, a #)
- { @newUDC#@ allocates a new application of an
+ { @newNullaryClosure#@ allocates a new application of an
unlifted data constructor (identified by its info table). }
with
effect = ReadWriteEffect
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -107,7 +107,7 @@ bcoFreeNames bco
assembleBCOs
:: Profile
-> FlatBag (ProtoBCO Name)
- -> FlatBag UnlinkedUDC
+ -> FlatBag UnlinkedNullaryClosure
-> [TyCon]
-> [(Name, ByteString)]
-> Maybe InternalModBreaks
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -59,7 +59,7 @@ linkBCO
-> PkgsLoaded
-> LinkerEnv
-> LinkedBreaks
- -> NameEnv Int -- Named UDCs
+ -> NameEnv Int -- Named NullaryClosures
-> NameEnv Int -- Named BCOs
-> UnlinkedBCO
-> IO ResolvedBCO
@@ -161,13 +161,13 @@ resolvePtr
-> PkgsLoaded
-> LinkerEnv
-> LinkedBreaks
- -> NameEnv Int -- Named UDCs
+ -> NameEnv Int -- Named NullaryClosures
-> NameEnv Int -- Named BCOs
-> BCOPtr
-> IO ResolvedBCOPtr
resolvePtr interp pkgs_loaded le lb udc_ix bco_ix ptr = case ptr of
BCOPtrName nm
- | Just ix <- lookupNameEnv udc_ix nm -- ref to another UDC in this group
+ | Just ix <- lookupNameEnv udc_ix nm -- ref to another NullaryClosure in this group
-> return (ResolvedBCORefUnlifted ix)
| Just ix <- lookupNameEnv bco_ix nm -- ref to another BCO in this group
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -16,7 +16,7 @@ module GHC.ByteCode.Types
, RegBitmap(..)
, NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
, ByteOff(..), WordOff(..), HalfWord(..)
- , UnlinkedUDC(..)
+ , UnlinkedNullaryClosure(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, AddrEnv, AddrPtr(..)
@@ -62,7 +62,7 @@ data CompiledByteCode = CompiledByteCode
{ bc_bcos :: FlatBag UnlinkedBCO
-- ^ Bunch of interpretable bindings
- , bc_udcs :: FlatBag UnlinkedUDC
+ , bc_udcs :: FlatBag UnlinkedNullaryClosure
, bc_itbls :: [(Name, ConInfoTable)]
-- ^ Mapping from DataCons to their info tables
@@ -178,16 +178,16 @@ newtype AddrPtr = AddrPtr (RemotePtr ())
{- |
Named reference to an unlifted data constructor
-}
-data UnlinkedUDC
- = UnlinkedUDC {
- unlinkedUDCName :: !Name,
- unlinkedUDCInfo :: !ConInfoTable
+data UnlinkedNullaryClosure
+ = UnlinkedNullaryClosure {
+ unlinkedNullaryClosureName :: !Name,
+ unlinkedNullaryClosureInfo :: !ConInfoTable
}
-instance NFData UnlinkedUDC where
- rnf UnlinkedUDC{..} =
- rnf unlinkedUDCName `seq`
- rnf unlinkedUDCInfo
+instance NFData UnlinkedNullaryClosure where
+ rnf UnlinkedNullaryClosure{..} =
+ rnf unlinkedNullaryClosureName `seq`
+ rnf unlinkedNullaryClosureInfo
{-
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -1019,21 +1019,21 @@ linkSomeBCOs :: Interp
linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
where
- fun :: CompiledByteCode -> ([([UnlinkedUDC], [UnlinkedBCO])] -> t) -> [([UnlinkedUDC], [UnlinkedBCO])] -> t
+ fun :: CompiledByteCode -> ([([UnlinkedNullaryClosure], [UnlinkedBCO])] -> t) -> [([UnlinkedNullaryClosure], [UnlinkedBCO])] -> t
fun CompiledByteCode{..} inner accum =
inner ((Foldable.toList bc_udcs, Foldable.toList bc_bcos) : accum)
- do_link :: [([UnlinkedUDC], [UnlinkedBCO])] -> IO [(Name, HValueRef)]
+ do_link :: [([UnlinkedNullaryClosure], [UnlinkedBCO])] -> IO [(Name, HValueRef)]
do_link [] = return []
do_link mods = do
- let flat_UDCs = [ udc | (udcs, _) <- mods, udc <- udcs ]
+ let flat_NullaryClosures = [ udc | (udcs, _) <- mods, udc <- udcs ]
flat_BCOs = [ bco | (_, bcos) <- mods, bco <- bcos ]
- names_UDCs = map unlinkedUDCName flat_UDCs
+ names_NullaryClosures = map unlinkedNullaryClosureName flat_NullaryClosures
names_BCOs = map unlinkedBCOName flat_BCOs
index_BCO = mkNameEnv (zip names_BCOs [0 ..])
- index_UDC = mkNameEnv (zip names_UDCs [length names_BCOs ..])
+ index_NullaryClosure = mkNameEnv (zip names_NullaryClosures [length names_BCOs ..])
- resolved_BCOs <- sequence [ linkBCO interp pkgs_loaded le lb index_UDC index_BCO bco | bco <- flat_BCOs ]
+ resolved_BCOs <- sequence [ linkBCO interp pkgs_loaded le lb index_NullaryClosure index_BCO bco | bco <- flat_BCOs ]
hvrefs <- createBCOs interp resolved_BCOs
return (zip names_BCOs hvrefs)
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -103,7 +103,7 @@ import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT(..))
import Data.Bifunctor (Bifunctor(..))
-import GHCi.ResolvedBCO (ResolvedUDC(..))
+import GHCi.ResolvedBCO (ResolvedNullaryClosure(..))
-- -----------------------------------------------------------------------------
@@ -310,7 +310,7 @@ argBits platform (rep : args)
-- Compile code for the right-hand side of a top-level binding
-schemeTopBind :: (Id, CgStgRhs) -> BcM (Either UnlinkedUDC (ProtoBCO Name))
+schemeTopBind :: (Id, CgStgRhs) -> BcM (Either UnlinkedNullaryClosure (ProtoBCO Name))
schemeTopBind (id, rhs)
| isUnliftedType (varType id), StgRhsCon _ dCon conNo _ _ _ <- rhs = do
profile <- getProfile
@@ -334,8 +334,8 @@ schemeTopBind (id, rhs)
Numbered i -> i
NoNumber -> 0 -- This defaulting seems unsafe?
- finalizer :: ConInfoTable -> Either UnlinkedUDC a
- finalizer = Left . UnlinkedUDC (getName id)
+ finalizer :: ConInfoTable -> Either UnlinkedNullaryClosure a
+ finalizer = Left . UnlinkedNullaryClosure (getName id)
pure . finalizer $ ConInfoTable
tables_next_to_code
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1771,7 +1771,7 @@ emitPrimOp cfg primop =
DataToTagSmallOp -> alwaysExternal
DataToTagLargeOp -> alwaysExternal
MkApUpd0_Op -> alwaysExternal
- NewUDCOp -> alwaysExternal
+ NewNullaryClosureOp -> alwaysExternal
NewBCOOp -> alwaysExternal
UnpackClosureOp -> alwaysExternal
ListThreadsOp -> alwaysExternal
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1164,7 +1164,7 @@ genPrim prof bound ty op = case op of
GetSparkOp -> unhandledPrimop op
AnyToAddrOp -> unhandledPrimop op
MkApUpd0_Op -> unhandledPrimop op
- NewUDCOp -> unhandledPrimop op
+ NewNullaryClosureOp -> unhandledPrimop op
NewBCOOp -> unhandledPrimop op
UnpackClosureOp -> unhandledPrimop op
ClosureSizeOp -> unhandledPrimop op
=====================================
libraries/ghci/GHCi/CreateBCO.hs
=====================================
@@ -14,7 +14,7 @@
--
-- | Create real byte-code objects from 'ResolvedBCO's and 'NullaryDataConApp's.
-module GHCi.CreateBCO (createBCOs, createUDCs) where
+module GHCi.CreateBCO (createBCOs, createNullaryClosures) where
import Prelude -- See note [Why do we import Prelude here?]
import GHCi.BreakArray
@@ -28,20 +28,20 @@ import Data.Array.Base
import Foreign hiding (newArray)
import Unsafe.Coerce (unsafeCoerce)
import GHC.Arr ( Array(..) )
-import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO#, newUDC# )
-import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO#, newUDC# )
+import GHC.Exts hiding ( BCO, mkApUpd0#, newBCO#, newNullaryClosure# )
+import GHC.Internal.Base ( BCO, mkApUpd0#, newBCO#, newNullaryClosure# )
import GHC.IO
import GHC.Exts.Heap ( StgInfoTable )
import Control.Exception ( ErrorCall(..) )
-createUDCs :: [RemotePtr StgInfoTable] -> IO [HValueRef]
-createUDCs dcas = do
- mapM createUnliftedDataConstructor dcas
+createNullaryClosures :: [RemotePtr StgInfoTable] -> IO [HValueRef]
+createNullaryClosures dcas = do
+ mapM createNullaryClosure dcas
-createUnliftedDataConstructor :: RemotePtr StgInfoTable -> IO HValueRef
-createUnliftedDataConstructor infoTablePtr =
+createNullaryClosure :: RemotePtr StgInfoTable -> IO HValueRef
+createNullaryClosure infoTablePtr =
let !(Ptr !addr#) = fromRemotePtr infoTablePtr
- in IO $ \s -> newUDC# addr# s
+ in IO $ \s -> newNullaryClosure# addr# s
createBCOs :: [ResolvedBCO] -> IO [HValueRef]
createBCOs bcos = do
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -106,7 +106,7 @@ data Message a where
-- see Note [Parallelize CreateBCOs serialization]
CreateBCOs :: [ResolvedBCO] -> Message [HValueRef]
- CreateUDCs :: [ResolvedUDC] -> Message [HValueRef]
+ CreateNullaryClosures :: [ResolvedNullaryClosure] -> Message [HValueRef]
-- | Release 'HValueRef's
FreeHValueRefs :: [HValueRef] -> Message ()
@@ -588,7 +588,7 @@ getMessage = do
38 -> Msg <$> (ResumeSeq <$> get)
39 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)
40 -> Msg <$> (WhereFrom <$> get)
- 41 -> Msg <$> (CreateUDCs <$> get)
+ 41 -> Msg <$> (CreateNullaryClosures <$> get)
_ -> error $ "Unknown Message code " ++ (show b)
putMessage :: Message a -> Put
@@ -635,7 +635,7 @@ putMessage m = case m of
ResumeSeq a -> putWord8 38 >> put a
LookupSymbolInDLL dll str -> putWord8 39 >> put dll >> put str
WhereFrom a -> putWord8 40 >> put a
- CreateUDCs ptr -> putWord8 41 >> put ptr
+ CreateNullaryClosures ptr -> putWord8 41 >> put ptr
{-
Note [Parallelize CreateBCOs serialization]
=====================================
libraries/ghci/GHCi/ResolvedBCO.hs
=====================================
@@ -4,7 +4,7 @@
module GHCi.ResolvedBCO
( ResolvedBCO(..)
, ResolvedBCOPtr(..)
- , ResolvedUDC(..)
+ , ResolvedNullaryClosure(..)
, isLittleEndian
, BCOByteArray(..)
, mkBCOByteArray
@@ -52,7 +52,7 @@ instance Binary ConInfoTable
instance NFData ConInfoTable
-- -----------------------------------------------------------------------------
--- ResolvedUDC
+-- ResolvedNullaryClosure
-- | A 'ResolvedBCO' is one in which all the 'Name' references have been
-- resolved to actual addresses or 'RemoteHValues'.
@@ -69,11 +69,11 @@ data ResolvedBCO
}
deriving (Generic, Show)
--- | A 'ResolvedUDC' is one in which all arguments have been applied to
+-- | A 'ResolvedNullaryClosure' is one in which all arguments have been applied to
-- a (potentially unlifted) data constructor.
-newtype ResolvedUDC
- = ResolvedUDC {
- unliftedDataConInfo :: ConInfoTable -- RemotePtr StgInfoTable
+newtype ResolvedNullaryClosure
+ = ResolvedNullaryClosure {
+ unliftedDataConInfo :: ConInfoTable
}
deriving (Binary, Generic, NFData, Show)
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -79,8 +79,8 @@ run m = case m of
MkConInfoTable infoTable -> convertInfoTable infoTable
ResolveObjs -> resolveObjs
FindSystemLibrary str -> findSystemLibrary str
- CreateUDCs dcas ->
- traverse (convertInfoTable . unliftedDataConInfo) dcas >>= createUDCs
+ CreateNullaryClosures dcas ->
+ traverse (convertInfoTable . unliftedDataConInfo) dcas >>= createNullaryClosures
CreateBCOs bcos -> createBCOs bcos
LookupClosure str -> lookupClosure str
#endif
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -83,6 +83,7 @@ library
GHCi.Utils
Build-Depends:
+ rts,
array == 0.5.*,
base >= 4.8 && < 4.23,
binary == 0.8.*,
@@ -94,7 +95,6 @@ library
ghc-heap >= 9.10.1 && <=@ProjectVersionMunged@,
ghc-internal >= 9.1001.0 && <=@ProjectVersionForLib@.0,
ghc-prim >= 0.5.0 && < 0.14,
- rts,
transformers >= 0.5 && < 0.7
if flag(bootstrap)
=====================================
rts/PrimOps.cmm
=====================================
@@ -2145,7 +2145,7 @@ stg_deRefStablePtrzh ( P_ sp )
Bytecode object primitives
------------------------------------------------------------------------- */
-stg_newUDHzh ( W_ datacon_itbl )
+stg_newNullaryClosurezh ( W_ datacon_itbl )
{
W_ p;
ALLOC_PRIM(SIZEOF_StgHeader);
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3022392cd8909a164dd528d85fb13a4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3022392cd8909a164dd528d85fb13a4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26519] PPC NCG: Fix shift right MO code
by Peter Trommler (＠trommler) 02 Dec '25
by Peter Trommler (＠trommler) 02 Dec '25
02 Dec '25
Peter Trommler pushed to branch wip/T26519 at Glasgow Haskell Compiler / GHC
Commits:
4a9ee3c5 by Peter Trommler at 2025-12-02T12:21:46+01:00
PPC NCG: Fix shift right MO code
The shift amount in shift right [arithmetic] MOs is machine word
width. Thereifore remove zero- or sign-entend shift amount.
It looks harmless to extend the shift amount argument because the
shift right instruction uses only the seven lowest bits (i. e. mod 128).
But now we have a conversion operation from a smaller type to word width
around a memory load at word width. The types are not matching up but
there is no check done in CodeGen. The necessary conversion from word
width down to the smaller width would be translated into a no-op on
PowerPC anyway. So all seems harmless if it was not for a small
optimisation in getRegister'.
In getRegister' a load instruction with the smaller width of the
conversion operation was generated. This the loaded the most significant
bits of the word in memory on a big-endian platform. These bits were
zero and hence shift right was used with shift amount zero and not one
as required in test Sized.
Fixes #26519
- - - - -
1 changed file:
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -469,48 +469,26 @@ getRegister' _ platform (CmmLoad mem pk _)
return (Any II64 code)
-- catch simple cases of zero- or sign-extended load
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
--- Note: there is no Load Byte Arithmetic instruction, so no signed case here
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do
- Amode addr addr_code <- getAmode D mem
- return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do
- -- lwa is DS-form. See Note [Power instruction format]
- Amode addr addr_code <- getAmode DS mem
- return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
+getRegister' _ _ (CmmMachOp (MO_UU_Conv src tgt) [CmmLoad mem pk _])
+ | src < tgt
+ , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt
+
+getRegister' _ _ (CmmMachOp (MO_XX_Conv src tgt) [CmmLoad mem pk _])
+ | src < tgt
+ , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt
+
+ -- XXX: This is ugly, refactor
+getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _])
+ -- Note: there is no Load Byte Arithmetic instruction
+ | cmmTypeFormat pk /= II8
+ , src < tgt = do
+ let format = cmmTypeFormat pk
+ -- lwa is DS-form. See Note [Power instruction format]
+ let form = if format >= II32 then DS else D
+ Amode addr addr_code <- getAmode form mem
+ let code dst = assert (format == intFormat src)
+ $ addr_code `snocOL` LA format dst addr
+ return (Any (intFormat tgt) code)
getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) =
getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned)
@@ -791,6 +769,12 @@ extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]
extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
+loadZeroExpand :: CmmExpr -> CmmType -> Width -> NatM Register
+loadZeroExpand mem pk tgt = do
+ Amode addr addr_code <- getAmode D mem
+ let code dst = addr_code `snocOL` LD (cmmTypeFormat pk) dst addr
+ return (Any (intFormat tgt) code)
+
-- -----------------------------------------------------------------------------
-- The 'Amode' type: Memory addressing modes passed up the tree.
@@ -2450,8 +2434,8 @@ srCode width sgn instr x y = do
let op_len = max W32 width
extend = if sgn then extendSExpr else extendUExpr
(src1, code1) <- getSomeReg (extend width op_len x)
- (src2, code2) <- getSomeReg (extendUExpr width op_len y)
- -- Note: Shift amount `y` is unsigned
+ (src2, code2) <- getSomeReg y
+
let code dst = code1 `appOL` code2 `snocOL`
instr (intFormat op_len) dst src1 (RIReg src2)
return (Any (intFormat width) code)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a9ee3c55a78ba84dfbc975a548e3dd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4a9ee3c55a78ba84dfbc975a548e3dd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0