[Git][ghc/ghc] Pushed new branch wip/int-index/enforce-namespaces
by Vladislav Zavialov (＠int-index) 23 Apr '25
by Vladislav Zavialov (＠int-index) 23 Apr '25
23 Apr '25
Vladislav Zavialov pushed new branch wip/int-index/enforce-namespaces at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/int-index/enforce-namespaces
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/az/ghc-cpp] Expose some Lexer bitmap manipulation helpers
by Alan Zimmerman (＠alanz) 23 Apr '25
by Alan Zimmerman (＠alanz) 23 Apr '25
23 Apr '25
Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC
Commits:
c88a8a4b by Alan Zimmerman at 2025-04-23T18:18:57+01:00
Expose some Lexer bitmap manipulation helpers
- - - - -
1 changed file:
- compiler/GHC/Parser/Lexer.x
Changes:
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -73,8 +73,8 @@ module GHC.Parser.Lexer (
ExtBits(..),
xtest, xunset, xset,
disableHaddock,
- enableGhcCpp,
- ghcCppEnabled,
+ enableGhcCpp, ghcCppEnabled,
+ enableExtBit, disableExtBit, extBitEnabled,
lexTokenStream,
mkParensEpToks,
mkParensLocs,
@@ -3152,12 +3152,23 @@ disableHaddock opts = upd_bitmap (xunset HaddockBit)
upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }
enableGhcCpp :: ParserOpts -> ParserOpts
-enableGhcCpp opts = upd_bitmap (xset GhcCppBit)
+enableGhcCpp = enableExtBit GhcCppBit
+
+ghcCppEnabled :: ParserOpts -> Bool
+ghcCppEnabled = extBitEnabled GhcCppBit
+
+enableExtBit :: ExtBits -> ParserOpts -> ParserOpts
+enableExtBit bit opts = upd_bitmap (xset bit)
where
upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }
-ghcCppEnabled :: ParserOpts -> Bool
-ghcCppEnabled opts = xtest GhcCppBit (pExtsBitmap opts)
+disableExtBit :: ExtBits -> ParserOpts -> ParserOpts
+disableExtBit bit opts = upd_bitmap (xunset bit)
+ where
+ upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) }
+
+extBitEnabled :: ExtBits -> ParserOpts -> Bool
+extBitEnabled bit opts = xtest bit (pExtsBitmap opts)
-- | Set parser options for parsing OPTIONS pragmas
initPragState :: p -> ParserOpts -> StringBuffer -> RealSrcLoc -> PState p
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c88a8a4bb158989f999278708c9ce7c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c88a8a4bb158989f999278708c9ce7c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Move -fno-code note into Downsweep module
by Marge Bot (＠marge-bot) 23 Apr '25
by Marge Bot (＠marge-bot) 23 Apr '25
23 Apr '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00
Move -fno-code note into Downsweep module
This note was left behind when all the code which referred to it was
moved into the GHC.Driver.Downsweep module
- - - - -
d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00
Apply editing notes to Note [-fno-code mode] suggested by sheaf
These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241
- - - - -
cd848c75 by Matthew Pickering at 2025-04-23T12:18:00-04:00
ghci: Use loadInterfaceForModule rather than loadSrcInterface in mkTopLevEnv
loadSrcInterface takes a user given `ModuleName` and resolves it to the
module which needs to be loaded (taking into account module
renaming/visibility etc).
loadInterfaceForModule takes a specific module and loads it.
The modules in `ImpDeclSpec` have already been resolved to the actual
module to get the information from during renaming. Therefore we just
need to fetch the precise interface from disk (and not attempt to rename
it again).
Fixes #25951
- - - - -
df8442ae by Simon Peyton Jones at 2025-04-23T12:18:01-04:00
Test for #23298
- - - - -
10 changed files:
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Runtime/Eval.hs
- + testsuite/tests/gadt/T23298.hs
- + testsuite/tests/gadt/T23298.stderr
- testsuite/tests/gadt/all.T
- + testsuite/tests/ghci/scripts/GhciPackageRename.hs
- + testsuite/tests/ghci/scripts/GhciPackageRename.script
- + testsuite/tests/ghci/scripts/GhciPackageRename.stdout
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
hostFullWays
in dflags_c
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code, no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+backend == NoBackend.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, there would be no need for -fwrite-interface as it
+would considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using Template Haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses Template Haskell to generate object
+code.
+
+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
+or not in the module which needs the code generation. If the module requires byte-code then
+dependencies will generate byte-code, otherwise they will generate object files.
+In the case where some modules require byte-code and some object files, both are
+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
+configurations.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for Template Haskell are written to temporary files.
+
+Note that since Template Haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+ mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+ .dyn_o. Fix it.
+* In make mode, a message like
+ Compiling A (A.hs, /tmp/ghc_123.o)
+ is shown if downsweep enabled object code generation for A. Perhaps we should
+ show "nothing" or "temporary object file" instead. Note that one
+ can currently use -keep-tmp-files and inspect the generated file with the
+ current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+ object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+ generating temporary ones.
+-}
+
-- | Populate the Downsweep cache with the root modules.
mkRootMap
:: [ModuleNodeInfo]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable =
, spt <- bc_spt_entries bco
]
-{- Note [-fno-code mode]
-~~~~~~~~~~~~~~~~~~~~~~~~
-GHC offers the flag -fno-code for the purpose of parsing and typechecking a
-program without generating object files. This is intended to be used by tooling
-and IDEs to provide quick feedback on any parser or type errors as cheaply as
-possible.
-
-When GHC is invoked with -fno-code no object files or linked output will be
-generated. As many errors and warnings as possible will be generated, as if
--fno-code had not been passed. The session DynFlags will have
-backend == NoBackend.
-
--fwrite-interface
-~~~~~~~~~~~~~~~~
-Whether interface files are generated in -fno-code mode is controlled by the
--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
-not also passed. Recompilation avoidance requires interface files, so passing
--fno-code without -fwrite-interface should be avoided. If -fno-code were
-re-implemented today, -fwrite-interface would be discarded and it would be
-considered always on; this behaviour is as it is for backwards compatibility.
-
-================================================================
-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
-================================================================
-
-Template Haskell
-~~~~~~~~~~~~~~~~
-A module using template haskell may invoke an imported function from inside a
-splice. This will cause the type-checker to attempt to execute that code, which
-would fail if no object files had been generated. See #8025. To rectify this,
-during the downsweep we patch the DynFlags in the ModSummary of any home module
-that is imported by a module that uses template haskell, to generate object
-code.
-
-The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
-or not in the module which needs the code generation. If the module requires byte-code then
-dependencies will generate byte-code, otherwise they will generate object files.
-In the case where some modules require byte-code and some object files, both are
-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
-configurations.
-
-The object files (and interface files if -fwrite-interface is disabled) produced
-for template haskell are written to temporary files.
-
-Note that since template haskell can run arbitrary IO actions, -fno-code mode
-is no more secure than running without it.
-
-Potential TODOS:
-~~~~~
-* Remove -fwrite-interface and have interface files always written in -fno-code
- mode
-* Both .o and .dyn_o files are generated for template haskell, but we only need
- .dyn_o. Fix it.
-* In make mode, a message like
- Compiling A (A.hs, /tmp/ghc_123.o)
- is shown if downsweep enabled object code generation for A. Perhaps we should
- show "nothing" or "temporary object file" instead. Note that one
- can currently use -keep-tmp-files and inspect the generated file with the
- current behaviour.
-* Offer a -no-codedir command line option, and write what were temporary
- object files there. This would speed up recompilation.
-* Use existing object files (if they are up to date) instead of always
- generating temporary ones.
--}
-- Note [When source is considered modified]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -78,7 +78,7 @@ import GHC.Core.Type hiding( typeKind )
import qualified GHC.Core.Type as Type
import GHC.Iface.Env ( newInteractiveBinder )
-import GHC.Iface.Load ( loadSrcInterface )
+import GHC.Iface.Load ( loadInterfaceForModule )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
@@ -843,7 +843,7 @@ mkTopLevEnv hsc_env modl
$ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv)
$ forM imports $ \iface_import -> do
let ImpUserSpec spec details = tcIfaceImport iface_import
- iface <- loadSrcInterface (text "imported by GHCi") (moduleName $ is_mod spec) (is_isboot spec) (is_pkg_qual spec)
+ iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec)
pure $ case details of
ImpUserAll -> importsFromIface hsc_env iface spec Nothing
ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns)
=====================================
testsuite/tests/gadt/T23298.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs #-}
+module T23298 where
+
+import Data.Kind (Type)
+
+type HList :: Type -> Type
+data HList a where
+ HCons :: HList x -> HList (Maybe x)
+
+eq :: HList a -> Bool
+eq x = case x of
+ HCons ms -> True
+
+go (HCons x) = go x
+
+{- go :: HList alpha -> beta
+
+Under HCons
+ [G] alpha ~ Maybe x
+ [W] HList x ~ HList alpha
+==>
+ [W] x ~ alpha
+==>
+ [W] x ~ Maybe x
+-}
=====================================
testsuite/tests/gadt/T23298.stderr
=====================================
@@ -0,0 +1,12 @@
+ T23298.hs:14:16: error: [GHC-25897]
+ • Couldn't match type ‘x’ with ‘Maybe x’
+ Expected: HList x -> t
+ Actual: HList a -> t
+ ‘x’ is a rigid type variable bound by
+ a pattern with constructor:
+ HCons :: forall x. HList x -> HList (Maybe x),
+ in an equation for ‘go’
+ at T23298.hs:14:5-11
+ • In the expression: go x
+ In an equation for ‘go’: go (HCons x) = go x
+ • Relevant bindings include x :: HList x (bound at T23298.hs:14:11)
=====================================
testsuite/tests/gadt/all.T
=====================================
@@ -131,3 +131,4 @@ test('T19847a', normalise_version('base'), compile, ['-ddump-types'])
test('T19847b', normal, compile, [''])
test('T23022', normal, compile, ['-dcore-lint'])
test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test?
+test('T23298', normal, compile_fail, [''])
=====================================
testsuite/tests/ghci/scripts/GhciPackageRename.hs
=====================================
@@ -0,0 +1,4 @@
+module GhciPackageRename where
+
+foo :: Map k v
+foo = empty
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/GhciPackageRename.script
=====================================
@@ -0,0 +1,6 @@
+:l GhciPackageRename.hs
+-- Test that Data.Map is available as Prelude
+:t fromList
+
+-- Test using a Map function
+fromList [(1,"a"), (2,"b")]
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/GhciPackageRename.stdout
=====================================
@@ -0,0 +1,3 @@
+fromList
+ :: ghc-internal:GHC.Internal.Classes.Ord k => [(k, a)] -> Map k a
+fromList [(1,"a"),(2,"b")]
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -386,3 +386,9 @@ test('T13869', extra_files(['T13869a.hs', 'T13869b.hs']), ghci_script, ['T13869.
test('ListTuplePunsPpr', normal, ghci_script, ['ListTuplePunsPpr.script'])
test('ListTuplePunsPprNoAbbrevTuple', [expect_broken(23135), limit_stdout_lines(13)], ghci_script, ['ListTuplePunsPprNoAbbrevTuple.script'])
test('T24459', normal, ghci_script, ['T24459.script'])
+
+# Test package renaming in GHCi session
+test('GhciPackageRename',
+ [extra_hc_opts("-hide-all-packages -package 'containers (Data.Map as Prelude)'")],
+ ghci_script,
+ ['GhciPackageRename.script'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e09173636dc453b10cf8949f96cf2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e09173636dc453b10cf8949f96cf2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
23 Apr '25
Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC
Commits:
0aac7dcc by Matthew Pickering at 2025-04-23T17:09:53+01:00
Fix docs
- - - - -
2 changed files:
- compiler/GHC/Driver/Session.hs
- docs/users_guide/using-warnings.rst
Changes:
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2265,6 +2265,7 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of
Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"
Opt_WarnCPPUndef -> warnSpec x
Opt_WarnBadlyLevelledTypes ->
+ warnSpec x ++
subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types"
Opt_WarnUnbangedStrictPatterns -> warnSpec x
Opt_WarnDeferredTypeErrors -> warnSpec x
=====================================
docs/users_guide/using-warnings.rst
=====================================
@@ -2554,7 +2554,7 @@ of ``-W(no-)*``.
that are not deprecating a name that is deprecated with another export in that module.
.. ghc-flag:: -Wbadly-levelled-types
- :shortdesc: warn when type binding is used at the wrong TH stage.
+ :shortdesc: warn when type binding is used at the wrong Template Haskell level.
:type: dynamic
:reverse: -Wno-badly-levelled-types
@@ -2565,11 +2565,21 @@ of ``-W(no-)*``.
tardy :: forall a. Proxy a -> IO Type
tardy _ = [t| a |]
- The type binding ``a`` is bound at stage 1 but used on stage 2.
+ The type binding ``a`` is bound at level 0 but used at level 1.
- This is badly staged program, and the ``tardy (Proxy @Int)`` won't produce
+ This is badly levelled program, and the ``tardy (Proxy @Int)`` won't produce
a type representation of ``Int``, but rather a local name ``a``.
+.. ghc-flag:: -Wbadly-staged-types
+ :shortdesc: A deprecated alias for :ghc-flag:`-Wbadly-levelled-types`
+ :type: dynamic
+ :reverse: -Wno-badly-staged-types
+
+ :since: 9.10.1
+
+ A deprecated alias for :ghc-flag:`-Wbadly-levelled-types`
+
+
.. ghc-flag:: -Winconsistent-flags
:shortdesc: warn when command line options are inconsistent in some way.
:type: dynamic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0aac7dcc195371d7ce82eac0f10d427…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0aac7dcc195371d7ce82eac0f10d427…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/T25898 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25898
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/T25968 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25968
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 2 commits: Use Module in IIModule
by Hannes Siebenhandl (＠fendor) 23 Apr '25
by Hannes Siebenhandl (＠fendor) 23 Apr '25
23 Apr '25
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
b7b39d81 by fendor at 2025-04-23T17:50:25+02:00
Use Module in IIModule
- - - - -
6e49609d by fendor at 2025-04-23T17:50:25+02:00
WIP
- - - - -
20 changed files:
- compiler/GHC.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/Home/Graph.hs
- ghc/GHCi/UI.hs
- testsuite/tests/ghci/linking/dyn/T3372.hs
- testsuite/tests/ghci/prog018/prog018.stdout
- testsuite/tests/ghci/scripts/T13869.stdout
- testsuite/tests/ghci/scripts/T13997.stdout
- testsuite/tests/ghci/scripts/T17669.stdout
- testsuite/tests/ghci/scripts/T18330.stdout
- testsuite/tests/ghci/scripts/T1914.stdout
- testsuite/tests/ghci/scripts/T20217.stdout
- testsuite/tests/ghci/scripts/T20587.stdout
- testsuite/tests/ghci/scripts/T6105.stdout
- testsuite/tests/ghci/scripts/T8042.stdout
- testsuite/tests/ghci/scripts/T8042recomp.stdout
- testsuite/tests/ghci/should_run/TopEnvIface.stdout
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -40,6 +40,7 @@ module GHC (
getProgramDynFlags, setProgramDynFlags,
updateProgramDynFlags,
getInteractiveDynFlags, setInteractiveDynFlags,
+ normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,
interpretPackageEnv,
-- * Logging
@@ -157,7 +158,7 @@ module GHC (
getBindings, getInsts, getNamePprCtx,
findModule, lookupModule,
findQualifiedModule, lookupQualifiedModule,
- lookupLoadedHomeModuleByModuleName, lookupAnyQualifiedModule,
+ lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,
renamePkgQualM, renameRawPkgQualM,
isModuleTrusted, moduleTrustReqs,
getNamesInScope,
@@ -962,24 +963,8 @@ getProgramDynFlags = getSessionDynFlags
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
logger <- getLogger
- dflags' <- checkNewDynFlags logger dflags
- dflags'' <- checkNewInteractiveDynFlags logger dflags'
- modifySessionM $ \hsc_env0 -> do
- let ic0 = hsc_IC hsc_env0
-
- -- Initialise (load) plugins in the interactive environment with the new
- -- DynFlags
- plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
- hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
-
- -- Update both plugins cache and DynFlags in the interactive context.
- return $ hsc_env0
- { hsc_IC = ic0
- { ic_plugins = hsc_plugins plugin_env
- , ic_dflags = hsc_dflags plugin_env
- }
- }
-
+ icdflags <- normaliseInteractiveDynFlags logger dflags
+ modifySessionM (initialiseInteractiveDynFlags icdflags)
-- | Get the 'DynFlags' used to evaluate interactive expressions.
getInteractiveDynFlags :: GhcMonad m => m DynFlags
@@ -1084,6 +1069,28 @@ normalise_hyp fp
-----------------------------------------------------------------------------
+normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
+normaliseInteractiveDynFlags logger dflags = do
+ dflags' <- checkNewDynFlags logger dflags
+ checkNewInteractiveDynFlags logger dflags'
+
+initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv
+initialiseInteractiveDynFlags dflags hsc_env0 = do
+ let ic0 = hsc_IC hsc_env0
+
+ -- Initialise (load) plugins in the interactive environment with the new
+ -- DynFlags
+ plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
+ hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }}
+
+ -- Update both plugins cache and DynFlags in the interactive context.
+ return $ hsc_env0
+ { hsc_IC = ic0
+ { ic_plugins = hsc_plugins plugin_env
+ , ic_dflags = hsc_dflags plugin_env
+ }
+ }
+
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
-- found, returns a fixed copy (if possible).
@@ -1496,8 +1503,8 @@ getModuleGraph = liftM hsc_mod_graph getSession
-- TODO: this function should likely be deleted.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env -> liftIO $ do
- hmi <- HUG.lookupAnyHug (hsc_HUG hsc_env) m
- return $! isJust hmi
+ hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m
+ return $! not (null hmis)
isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do
@@ -1895,18 +1902,16 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
--- TODO: this is incorrect, what if we have mulitple 'ModuleName's in our HPTs?
-lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module])
lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do
trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name)
- HUG.lookupAnyHug (hsc_HUG hsc_env) mod_name >>= \case
- Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
- _not_a_home_module -> return Nothing
+ HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case
+ [] -> return Nothing
+ mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos))
-lookupAnyQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
-lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
+lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module]
+lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do
home <- lookupLoadedHomeModuleByModuleName mod_name
- liftIO $ trace_if (hsc_logger hsc_env) (ppr home <+> ppr (fmap moduleUnitId home))
case home of
Just m -> return m
Nothing -> liftIO $ do
@@ -1916,11 +1921,11 @@ lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let fopts = initFinderOpts dflags
res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
case res of
- Found _ m -> return m
+ Found _ m -> return [m]
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
-lookupAnyQualifiedModule pkgqual mod_name =
- -- TODO: definitely wrong.
- findQualifiedModule pkgqual mod_name
+lookupAllQualifiedModuleNames pkgqual mod_name = do
+ m <- findQualifiedModule pkgqual mod_name
+ pure [m]
-- | Check that a module is safe to import (according to Safe Haskell).
--
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name
pick_interactive :: InteractiveImport -> Bool
pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True
| mod_name == fmap unLoc (ideclAs d) = True
- pick_interactive (IIModule m) | mod_name == Just m = True
+ pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True
pick_interactive _ = False
-- We want to keep only one for each original module; preferably one with an
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -296,9 +296,7 @@ data InteractiveImport
-- ^ Bring the exports of a particular module
-- (filtered by an import decl) into scope
- | IIModule ModuleName
- -- TODO: change this to 'Module', does this work?
- -- Much more precise
+ | IIModule Module
-- ^ Bring into scope the entire top-level envt of
-- of this module, including the things imported
-- into it.
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -822,17 +822,12 @@ findGlobalRdrEnv hsc_env imports
idecls :: [LImportDecl GhcPs]
idecls = [noLocA d | IIDecl d <- imports]
- imods :: [ModuleName]
+ imods :: [Module]
imods = [m | IIModule m <- imports]
- mkEnv modl = do
- -- TODO: revisit this, is this how we want to do it?
- mMod <- HUG.lookupAnyHug (hsc_HUG hsc_env) modl
- let mod = case mMod of
- Nothing -> mkModule (RealUnit $ Definite $ hscActiveUnitId hsc_env) modl
- Just m -> mi_module $ hm_iface m
+ mkEnv mod = do
mkTopLevEnv hsc_env mod >>= \case
- Left err -> pure $ Left (modl, err)
+ Left err -> pure $ Left (moduleName mod, err)
Right env -> pure $ Right env
mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv)
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.Annotations
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
-import GHC.Types.PkgQual
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Env as UnitEnv
@@ -2091,15 +2090,18 @@ runTcInteractive hsc_env thing_inside
, let local_gres = filter isLocalGRE gres
, not (null local_gres) ]) ]
- ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
- : dep_orphs (mi_deps iface))
- (loadSrcInterface (text "runTcInteractive") m
- NotBoot mb_pkg)
+ ; let getOrphansForModuleName m mb_pkg = do
+ iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg
+ pure $ mi_module iface : dep_orphs (mi_deps iface)
+
+ getOprhansForModule m = do
+ iface <- loadModuleInterface (text "runTcInteractive") m
+ pure $ mi_module iface : dep_orphs (mi_deps iface)
; !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))
+ IIModule n -> getOprhansForModule n
+ IIDecl i -> getOrphansForModuleName (unLoc (ideclName i))
(renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
=====================================
compiler/GHC/Unit/Home/Graph.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Unit.Home.Graph
, lookupHug
, lookupHugByModule
, lookupHugUnit
- , lookupAnyHug
+ , lookupAllHug
, memberHugHomeModule
, memberHugHomeInstalledModule
@@ -91,6 +91,7 @@ import GHC.Data.Graph.Directed
import GHC.Types.Annotations
import GHC.Types.CompleteMatch
import GHC.Core.InstEnv
+import GHC.Utils.Monad (mapMaybeM)
-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across
@@ -254,22 +255,17 @@ lookupHug hug uid mod = do
Nothing -> pure Nothing
Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod
--- TODO: this should not be merged, where else could we try to search for modules?
-lookupAnyHug :: HomeUnitGraph -> ModuleName -> IO (Maybe HomeModInfo)
-lookupAnyHug hug mod = firstJustM $ flip fmap (Set.toList $ unitEnv_keys hug) $ \uid -> do
- case unitEnv_lookup_maybe uid hug of
- -- Really, here we want "lookup HPT" rather than unitEnvLookup
- Nothing -> pure Nothing
- Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod
+-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'.
+-- 'ModuleName's are not unique in the case of multiple home units, so there can be
+-- more than one possible 'HomeModInfo'.
+lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo]
+lookupAllHug hug mod = mapMaybeM lookupModuleName (Set.toList $ unitEnv_keys hug)
where
- firstJustM :: Monad f => [f (Maybe a)] -> f (Maybe a)
- firstJustM [] = pure Nothing
- firstJustM (x:xs) = do
- ma <- x
- case ma of
- Nothing -> firstJustM xs
- Just a -> pure $ Just a
-
+ lookupModuleName uid =
+ case unitEnv_lookup_maybe uid hug of
+ -- Really, here we want "lookup HPT" rather than unitEnvLookup
+ Nothing -> pure Nothing
+ Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod
-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit)
lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
@@ -283,10 +279,12 @@ lookupHugByModule mod hug
lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
lookupHugUnit = unitEnv_lookup_maybe
+-- | Check whether the 'Module' is part of the given 'HomeUnitGraph'.
memberHugHomeModule :: Module -> HomeUnitGraph -> Bool
memberHugHomeModule mod =
memberHugHomeInstalledModule (fmap toUnitId mod)
+-- | Check whether the 'InstalledModule' is part of the given 'HomeUnitGraph'.
memberHugHomeInstalledModule :: InstalledModule -> HomeUnitGraph -> Bool
memberHugHomeInstalledModule mod hug =
case unitEnv_lookup_maybe (moduleUnit mod) hug of
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -558,7 +558,7 @@ interactiveUI config srcs maybe_exprs = do
hsc_env <- GHC.getSession
let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 3
-- We force this to make sure we don't retain the hsc_env when reloading
- -- The check is `> 2`, since we now always have at least two home units.
+ -- The check is `> 3`, since we now always have at least two home units.
-- TODO: if everything goes well, this check should be deleted once
-- this PR has lifted the multiple home unit restrictions
empty_cache <- liftIO newIfaceCache
@@ -1023,7 +1023,7 @@ getInfoForPrompt = do
| otherwise = unLoc (ideclName d)
modules_names =
- ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
+ ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++
[moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
line = 1 + line_number st
@@ -1444,7 +1444,6 @@ runStmt input step = do
setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500
setDumpFilePrefix ic = do
- -- TODO: wrong
dflags <- GHC.getInteractiveDynFlags
GHC.setInteractiveDynFlags dflags { dumpPrefix = modStr ++ "." }
where
@@ -2122,7 +2121,7 @@ addModule :: GhciMonad m => [FilePath] -> m ()
addModule files = do
revertCAFs -- always revert CAFs on load/add.
files' <- mapM expandPath files
- targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
targets' <- filterM checkTarget targets
-- remove old targets with the same id; e.g. for :add *M
mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ]
@@ -2155,7 +2154,7 @@ addModule files = do
unAddModule :: GhciMonad m => [FilePath] -> m ()
unAddModule files = do
files' <- mapM expandPath files
- targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
+ targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
let removals = [ tid | Target { targetId = tid } <- targets ]
mapM_ GHC.removeTarget removals
_ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets
@@ -2279,7 +2278,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do
-- We import the module with a * iff
-- - it is interpreted, and
-- - -XSafe is off (it doesn't allow *-imports)
- let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
+ let new_ctx | star_ok = [mkIIModule m]
| otherwise = [mkIIDecl (GHC.moduleName m)]
setContextKeepingPackageModules keep_ctxt new_ctx
@@ -2699,7 +2698,7 @@ guessCurrentModule cmd = do
imports <- GHC.getContext
case imports of
[] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
- IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+ IIModule m : _ -> pure m
IIDecl d : _ -> do
pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
@@ -2829,8 +2828,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do
addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
addModulesToContext_ starred unstarred = do
- mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
- setGHCContextFromGHCiState
+ starredModules <- traverse lookupModuleName starred
+ mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred)
+ setGHCContextFromGHCiState
remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
remModulesFromContext starred unstarred = do
@@ -2896,9 +2896,9 @@ checkAdd ii = do
dflags <- getDynFlags
let safe = safeLanguageOn dflags
case ii of
- IIModule modname
+ IIModule mod
| safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
- | otherwise -> wantInterpretedModuleName modname >> return ()
+ | otherwise -> checkInterpretedModule mod >> return ()
IIDecl d -> do
let modname = unLoc (ideclName d)
@@ -2966,13 +2966,13 @@ getImplicitPreludeImports iidecls = do
-- -----------------------------------------------------------------------------
-- Utils on InteractiveImport
-mkIIModule :: ModuleName -> InteractiveImport
+mkIIModule :: Module -> InteractiveImport
mkIIModule = IIModule
mkIIDecl :: ModuleName -> InteractiveImport
mkIIDecl = IIDecl . simpleImportDecl
-iiModules :: [InteractiveImport] -> [ModuleName]
+iiModules :: [InteractiveImport] -> [Module]
iiModules is = [m | IIModule m <- is]
isIIModule :: InteractiveImport -> Bool
@@ -2980,7 +2980,7 @@ isIIModule (IIModule _) = True
isIIModule _ = False
iiModuleName :: InteractiveImport -> ModuleName
-iiModuleName (IIModule m) = m
+iiModuleName (IIModule m) = moduleName m
iiModuleName (IIDecl d) = unLoc (ideclName d)
preludeModuleName :: ModuleName
@@ -3239,22 +3239,30 @@ newDynFlags interactive_only minus_opts = do
let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv
-- TODO: perhaps write custom version of parseDynamicFlagsCmdLine which gives us more control over the errors and warnings
(newFlags, _, _) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts
- let newFlags' = if uid == interactiveGhciUnitId
- then wopt_unset newFlags Opt_WarnUnusedPackages
- else newFlags
+ newFlags' <-
+ if uid == interactiveGhciUnitId || uid == interactiveSessionUnitId
+ then do
+ -- TODO: document this
+ let dflags1 = wopt_unset newFlags Opt_WarnUnusedPackages
+ if uid == interactiveGhciUnitId
+ then
+ GHC.normaliseInteractiveDynFlags logger dflags1
+ else
+ pure dflags1
+ else
+ pure newFlags
pure (uid, oldFlags, newFlags')
must_reload <- GHC.updateProgramDynFlags True updates
-- update and check interactive dynflags
-- TODO: document the relation ship between the interactive unit and in the interactive context
icdflags <- hsc_dflags <$> GHC.getSession
- GHC.setInteractiveDynFlags icdflags
+ modifySessionM (GHC.initialiseInteractiveDynFlags icdflags)
-- if the package flags changed, reset the context and link
-- the new packages.
hsc_env <- GHC.getSession
let dflags2 = hsc_dflags hsc_env
- let interp = hscInterp hsc_env
when must_reload $ do
when (verbosity dflags2 > 0) $
liftIO . putStrLn $
@@ -3263,30 +3271,41 @@ newDynFlags interactive_only minus_opts = do
-- Clear caches and eventually defined breakpoints. (#1620)
clearCaches
- let units = concatMap (preloadUnits . HUG.homeUnitEnv_units) (Foldable.toList $ hsc_HUG hsc_env)
- liftIO $ Loader.loadPackages interp hsc_env units
- -- package flags changed, we can't re-use any of the old context
- setContextAfterLoad False Nothing -- TODO: recheck whether this is necessary
-
- -- TODO extract into separate function
- let ld0length = length $ ldInputs dflags0
- fmrk0length = length $ cmdlineFrameworks dflags0
-
- newLdInputs = drop ld0length (ldInputs dflags2)
- newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
+ reloadPackages hsc_env
- dflags' = dflags2 { ldInputs = newLdInputs
- , cmdlineFrameworks = newCLFrameworks
- }
- hsc_env' = hscSetFlags dflags' hsc_env
-
- when (not (null newLdInputs && null newCLFrameworks)) $
- liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
+ reloadLinkerOptions hsc_env dflags0 dflags2
idflags <- hsc_dflags <$> GHC.getSession
installInteractivePrint (interactivePrint idflags) False
return ()
+reloadPackages :: GhciMonad m => HscEnv -> m ()
+reloadPackages hsc_env = do
+ let
+ units =
+ concatMap (preloadUnits . HUG.homeUnitEnv_units)
+ (Foldable.toList $ hsc_HUG hsc_env)
+ liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units
+ -- package flags changed, we can't re-use any of the old context
+ setContextAfterLoad False Nothing
+
+reloadLinkerOptions :: MonadIO m => HscEnv -> DynFlags -> DynFlags -> m ()
+reloadLinkerOptions hsc_env old_flags new_flags = do
+ let
+
+ ld0length = length $ ldInputs old_flags
+ fmrk0length = length $ cmdlineFrameworks old_flags
+
+ newLdInputs = drop ld0length (ldInputs new_flags)
+ newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags)
+
+ dflags' = new_flags { ldInputs = newLdInputs
+ , cmdlineFrameworks = newCLFrameworks
+ }
+ hsc_env' = hscSetFlags dflags' hsc_env
+
+ when (not (null newLdInputs && null newCLFrameworks)) $
+ liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
unknownFlagsErr :: GhciMonad m => [String] -> m ()
unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs
@@ -3428,7 +3447,7 @@ showImports = do
trans_ctx = transient_ctx st
show_one (IIModule star_m)
- = ":module +*" ++ moduleNameString star_m
+ = ":module +*" ++ moduleNameString (moduleName star_m)
show_one (IIDecl imp) = showPpr dflags imp
prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
@@ -3734,11 +3753,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
filterM GHC.moduleIsInterpreted hmods
-- Return all possible bids for a given Module
- bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
+ bidsByModule :: GhciMonad m => [Module] -> Module -> m [String]
bidsByModule nonquals mod = do
(_, decls) <- getModBreak mod
let bids = nub $ declPath <$> elems decls
- pure $ case (moduleName mod) `elem` nonquals of
+ pure $ case mod `elem` nonquals of
True -> bids
False -> (combineModIdent (showModule mod)) <$> bids
@@ -4143,8 +4162,7 @@ breakSwitch (arg1:rest)
| all isDigit arg1 = do
imports <- GHC.getContext
case iiModules imports of
- (mn : _) -> do
- md <- lookupModuleName mn
+ (md : _) -> do
breakByModuleLine md (read arg1) rest
[] -> do
liftIO $ putStrLn "No modules are loaded with debugging support."
@@ -4276,8 +4294,7 @@ list2 [arg] | all isDigit arg = do
case iiModules imports of
[] -> liftIO $ putStrLn "No module to list"
(mn : _) -> do
- md <- lookupModuleName mn
- listModuleLine md (read arg)
+ listModuleLine mn (read arg)
list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
md <- wantInterpretedModule arg1
listModuleLine md (read arg2)
@@ -4536,7 +4553,17 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName
lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module
-lookupQualifiedModuleName = GHC.lookupAnyQualifiedModule
+lookupQualifiedModuleName qual modl = do
+ GHC.lookupAllQualifiedModuleNames qual modl >>= \case
+ [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found."))
+ [m] -> pure m
+ ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous;\n" ++ errorMsg ms))
+ where
+ str = moduleNameString modl
+ errorMsg ms = intercalate "\n"
+ [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m)
+ | m <- ms
+ ]
isMainUnitModule :: Module -> Bool
isMainUnitModule m = GHC.moduleUnit m == mainUnit
@@ -4586,15 +4613,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
wantInterpretedModuleName modname = do
- modl <- lookupModuleName modname
- let str = moduleNameString modname
- hug <- hsc_HUG <$> GHC.getSession
- unless (HUG.memberHugHomeModule modl hug) $
- throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
- is_interpreted <- GHC.moduleIsInterpreted modl
- when (not is_interpreted) $
- throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
- return modl
+ modl <- lookupModuleName modname
+ checkInterpretedModule modl
+
+checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module
+checkInterpretedModule modl = do
+ let str = moduleNameString $ moduleName modl
+ hug <- hsc_HUG <$> GHC.getSession
+ unless (HUG.memberHugHomeModule modl hug) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+ is_interpreted <- GHC.moduleIsInterpreted modl
+ when (not is_interpreted) $
+ throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+ return modl
wantNameFromInterpretedModule :: GHC.GhcMonad m
=> (Name -> SDoc -> m ())
=====================================
testsuite/tests/ghci/linking/dyn/T3372.hs
=====================================
@@ -60,7 +60,7 @@ load (f,mn) = do target <- GHC.guessTarget f Nothing Nothing
GHC.liftIO $ putStrLn ("Load " ++ showSuccessFlag res)
--
m <- GHC.findModule (GHC.mkModuleName mn) Nothing
- GHC.setContext [GHC.IIModule $ GHC.moduleName $ m]
+ GHC.setContext [GHC.IIModule m]
where showSuccessFlag GHC.Succeeded = "succeeded"
showSuccessFlag GHC.Failed = "failed"
=====================================
testsuite/tests/ghci/prog018/prog018.stdout
=====================================
@@ -1,6 +1,6 @@
-[1 of 3] Compiling A ( A.hs, interpreted )
-[2 of 3] Compiling B ( B.hs, interpreted )
-[3 of 3] Compiling C ( C.hs, interpreted )
+[1 of 3] Compiling A ( A.hs, interpreted )[main]
+[2 of 3] Compiling B ( B.hs, interpreted )[main]
+[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session]
A.hs:5:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)]
Pattern match(es) are non-exhaustive
In an equation for ‘incompletePattern’:
@@ -18,7 +18,7 @@ C.hs:6:7: error: [GHC-88464]
Variable not in scope: variableNotInScope :: ()
Failed, two modules loaded.
-[3 of 3] Compiling C ( C.hs, interpreted )
+[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session]
C.hs:6:7: error: [GHC-88464]
Variable not in scope: variableNotInScope :: ()
=====================================
testsuite/tests/ghci/scripts/T13869.stdout
=====================================
@@ -1,14 +1,14 @@
-[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )
+[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session]
Ok, one module loaded.
Ok, one module reloaded.
Ok, unloaded all modules.
Ok, no modules to be reloaded.
-[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )
+[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session]
Ok, one module loaded.
-[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )
+[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session]
Ok, one module added.
Ok, two modules reloaded.
-[1 of 2] Compiling T13869A ( T13869a.hs, interpreted )
-[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )
+[1 of 2] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session]
+[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session]
Ok, two modules loaded.
Ok, one module unadded.
=====================================
testsuite/tests/ghci/scripts/T13997.stdout
=====================================
@@ -1,8 +1,8 @@
-[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o )
-[2 of 2] Compiling Bug ( Bug.hs, Bug.o )
+[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o )[main]
+[2 of 2] Compiling Bug ( Bug.hs, Bug.o )[interactive-session]
Ok, two modules loaded.
-[1 of 3] Compiling New ( New.hs, New.o )
-[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o ) [Source file changed]
-[3 of 3] Compiling Bug ( Bug.hs, Bug.o ) [Bug2 changed]
+[1 of 3] Compiling New ( New.hs, New.o )[main]
+[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o )[main] [Source file changed]
+[3 of 3] Compiling Bug ( Bug.hs, Bug.o )[interactive-session] [Bug2 changed]
Ok, three modules reloaded.
True
=====================================
testsuite/tests/ghci/scripts/T17669.stdout
=====================================
@@ -1,6 +1,6 @@
-[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )
+[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session]
Ok, one module loaded.
this
-[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) [Source file changed]
+[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session] [Source file changed]
Ok, one module reloaded.
that
=====================================
testsuite/tests/ghci/scripts/T18330.stdout
=====================================
@@ -1,9 +1,8 @@
-GHCi, version 9.3.20211019: https://www.haskell.org/ghc/ :? for help
-ghci> [1 of 2] Compiling Main ( shell.hs, interpreted )
-[2 of 2] Linking shell
+GHCi, version 9.13.20250422: https://www.haskell.org/ghc/ :? for help
+ghci> [1 of 2] Compiling Main ( shell.hs, interpreted )[interactive-session]
Ok, one module loaded.
-ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )
-Ok, one module loaded.
-ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) [T18330.extra changed]
+ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session]
Ok, one module loaded.
+ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session] [T18330.extra changed]
+Ok, one module reloaded.
ghci> Leaving GHCi.
=====================================
testsuite/tests/ghci/scripts/T1914.stdout
=====================================
@@ -1,7 +1,7 @@
-[1 of 2] Compiling T1914B ( T1914B.hs, interpreted )
-[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )
+[1 of 2] Compiling T1914B ( T1914B.hs, interpreted )[main]
+[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session]
Ok, two modules loaded.
-[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) [Source file changed]
+[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] [Source file changed]
Failed, one module reloaded.
-[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )
+[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session]
Ok, two modules reloaded.
=====================================
testsuite/tests/ghci/scripts/T20217.stdout
=====================================
@@ -1,5 +1,5 @@
-[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing )
-[2 of 3] Compiling T20217A ( T20217A.hs, nothing )
-[3 of 3] Compiling T20217 ( T20217.hs, nothing )
+[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing )[main]
+[2 of 3] Compiling T20217A ( T20217A.hs, nothing )[main]
+[3 of 3] Compiling T20217 ( T20217.hs, nothing )[interactive-session]
Ok, three modules loaded.
Ok, three modules reloaded.
=====================================
testsuite/tests/ghci/scripts/T20587.stdout
=====================================
@@ -1,4 +1,4 @@
-[1 of 1] Compiling B
+[1 of 1] Compiling B[interactive-session]
Ok, one module loaded.
-[1 of 1] Compiling B [Source file changed]
+[1 of 1] Compiling B[interactive-session] [Source file changed]
Ok, one module reloaded.
=====================================
testsuite/tests/ghci/scripts/T6105.stdout
=====================================
@@ -1,4 +1,4 @@
-[1 of 1] Compiling T6105 ( T6105.hs, interpreted )
+[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session]
Ok, one module loaded.
-[1 of 1] Compiling T6105 ( T6105.hs, interpreted )
+[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session]
Ok, one module reloaded.
=====================================
testsuite/tests/ghci/scripts/T8042.stdout
=====================================
@@ -1,9 +1,9 @@
-[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o )
-[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )
-[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )
+[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o )[main]
+[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main]
+[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session]
Ok, three modules loaded.
-[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o ) [Source file changed]
+[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session] [Source file changed]
Ok, three modules reloaded.
-[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )
-[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )
+[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main]
+[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session]
Ok, three modules loaded.
=====================================
testsuite/tests/ghci/scripts/T8042recomp.stdout
=====================================
@@ -1,6 +1,6 @@
-[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o )
-[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o )
+[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o )[main]
+[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session]
Ok, two modules loaded.
-[2 of 2] Compiling T8042A ( T8042A.hs, interpreted )
+[2 of 2] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session]
Ok, two modules loaded.
Breakpoint 0 activated at T8042A.hs:1:44-56
=====================================
testsuite/tests/ghci/should_run/TopEnvIface.stdout
=====================================
@@ -1,5 +1,5 @@
-[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted )
-[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted )
+[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted )[main]
+[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted )[main]
Ok, two modules loaded.
"I should be printed twice"
Leaving GHCi.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b33…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b33…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Ben Gamari pushed new branch wip/T25989 at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25989
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/splice-imports-2025] 3 commits: downsweep: Move functions to top level and use DownsweepM monad
by Matthew Pickering (＠mpickering) 23 Apr '25
by Matthew Pickering (＠mpickering) 23 Apr '25
23 Apr '25
Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC
Commits:
e124b9ef by Matthew Pickering at 2025-04-23T14:42:53+01:00
downsweep: Move functions to top level and use DownsweepM monad
This refactoring moves the functions in GHC.Driver.Downsweep to the
top-level (rather than a very long where clause), and uses a monad to
thread around the relevant configuration options.
In the splice improrts patch, I need to use a different entry point into
these functions, so I have separated this refactoring into a separate
commit.
- - - - -
a55ce077 by Matthew Pickering at 2025-04-23T15:20:56+01:00
GHCi and tests
- - - - -
4b4b4c5a by Matthew Pickering at 2025-04-23T16:35:03+01:00
Test self-edges
- - - - -
19 changed files:
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/Stage.hs
- ghc/GHCi/UI.hs
- + testsuite/tests/splice-imports/SI30.stdout
- + testsuite/tests/splice-imports/SI31.script
- + testsuite/tests/splice-imports/SI31.stderr
- + testsuite/tests/splice-imports/SI32.script
- + testsuite/tests/splice-imports/SI32.stdout
- + testsuite/tests/splice-imports/SI33.script
- + testsuite/tests/splice-imports/SI33.stdout
- + testsuite/tests/splice-imports/SI34.hs
- + testsuite/tests/splice-imports/SI34.stderr
- + testsuite/tests/splice-imports/SI34M1.hs
- + testsuite/tests/splice-imports/SI34M2.hs
- + testsuite/tests/splice-imports/SI35.hs
- + testsuite/tests/splice-imports/SI35A.hs
- testsuite/tests/splice-imports/all.T
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -13,6 +13,7 @@ module GHC.Driver.Downsweep
, downsweepThunk
, downsweepInstalledModules
, downsweepFromRootNodes
+ , downsweepInteractiveImports
, DownsweepMode(..)
-- * Summary functions
, summariseModule
@@ -49,6 +50,9 @@ import GHC.Iface.Load
import GHC.Parser.Header
import GHC.Rename.Names
import GHC.Tc.Utils.Backpack
+import GHC.Runtime.Context
+
+import Language.Haskell.Syntax.ImpExp
import GHC.Data.Graph.Directed
import GHC.Data.FastString
@@ -76,6 +80,8 @@ import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.Map
import GHC.Types.PkgQual
+import GHC.Types.Basic
+
import GHC.Unit
import GHC.Unit.Env
@@ -236,6 +242,46 @@ downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
(GhcDriverMessage <$> unionManyMessages errs)
return (mkModuleGraph mg)
+-- | Construct a module graph starting from the interactive context.
+-- Produces, a thunk, which when forced will perform the downsweep.
+-- This graph contains the current interactive module, and its dependencies.
+
+-- This is a first approximation for this function.
+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph
+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
+ let imps = ic_imports (hsc_IC hsc_env)
+
+ let mn = icInteractiveModule ic
+ let ml = pprPanic "withInteractiveModuleNode" (ppr mn <+> ppr imps)
+ let key = moduleToMnk mn NotBoot
+ let node_type = ModuleNodeFixed key ml
+
+ let edges = map mkEdge imps
+ let env = DownsweepEnv hsc_env DownsweepUseCompile mempty []
+ (module_edges, graph, _) <- runDownsweepM env $ loopImports edges M.empty Map.empty
+ let node = ModuleNode module_edges node_type
+
+ let all_nodes = M.elems graph
+ let graph = mkModuleGraph (node : all_nodes)
+
+ return graph
+
+ where
+ --
+ mkEdge :: InteractiveImport -> (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))
+ -- A simple edge to a module from the same home unit
+ mkEdge (IIModule n) =
+ let unitId = homeUnitId $ hsc_home_unit hsc_env
+ in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot)
+ -- A complete import statement
+ mkEdge (IIDecl i) =
+ let lvl = convImportLevel (ideclLevelSpec i)
+ wanted_mod = unLoc (ideclName i)
+ is_boot = ideclSource i
+ mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)
+ unitId = homeUnitId $ hsc_home_unit hsc_env
+ in (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)
+
-- | Create a module graph from a list of installed modules.
-- This is used by the loader when we need to load modules but there
-- isn't already an existing module graph. For example, when loading plugins
@@ -298,13 +344,16 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
= do
let root_map = mkRootMap root_nodes
checkDuplicates root_map
- (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
- let all_deps = loopUnit hsc_env module_deps root_uids
+ let env = DownsweepEnv hsc_env mode old_summaries excl_mods
+ (deps', map0) <- runDownsweepM env $ do
+ (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)
+ let all_deps = loopUnit hsc_env module_deps root_uids
+ let all_instantiations = getHomeUnitInstantiations hsc_env
+ deps' <- loopInstantiations all_instantiations all_deps
+ return (deps', map0)
- let all_instantiations = getHomeUnitInstantiations hsc_env
- let deps' = loopInstantiations all_instantiations all_deps
- downsweep_errs = lefts $ concat $ M.elems map0
+ let downsweep_errs = lefts $ concat $ M.elems map0
downsweep_nodes = M.elems deps'
return (downsweep_errs, downsweep_nodes)
@@ -312,14 +361,6 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]
getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)
-
- calcDeps ms =
- -- Add a dependency on the HsBoot file if it exists
- -- This gets passed to the loopImports function which just ignores it if it
- -- can't be found.
- [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
- [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]
-
-- In a root module, the filename is allowed to diverge from the module
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
@@ -335,208 +376,231 @@ downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root
dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2
dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
- loopInstantiations :: [(UnitId, InstantiatedUnit)]
- -> M.Map NodeKey ModuleGraphNode
- -> M.Map NodeKey ModuleGraphNode
- loopInstantiations [] done = done
- loopInstantiations ((home_uid, iud) :xs) done =
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
- payload = InstantiationNode home_uid iud
- in loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
-
- where
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
-
-
- -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
- loopSummaries :: [ModSummary]
- -> (M.Map NodeKey ModuleGraphNode,
- DownsweepCache)
- -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
- loopSummaries [] done = return done
- loopSummaries (ms:next) (done, summarised)
- | Just {} <- M.lookup k done
- = loopSummaries next (done, summarised)
- -- Didn't work out what the imports mean yet, now do that.
- | otherwise = do
- (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
- -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
- (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
- loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
- where
- k = NodeKey_Module (msKey ms)
-
- hs_file_for_boot
- | HsBootFile <- ms_hsc_src ms
- = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
- | otherwise
- = Nothing
-
- loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
- loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
-
- loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache)
- loopModuleNodeInfo mod_node_info (done, summarised) = do
- case mod_node_info of
- ModuleNodeCompile ms -> do
- loopSummaries [ms] (done, summarised)
- ModuleNodeFixed mod ml -> do
- done' <- loopFixedModule mod ml done
- return (done', summarised)
-
- -- NB: loopFixedModule does not take a downsweep cache, because if you
- -- ever reach a Fixed node, everything under that also must be fixed.
- loopFixedModule :: ModNodeKeyWithUid -> ModLocation
- -> M.Map NodeKey ModuleGraphNode
- -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedModule key loc done = do
- let nk = NodeKey_Module key
- case M.lookup nk done of
- Just {} -> return done
- Nothing -> do
- -- MP: TODO, we should just read the dependency info from the interface rather than either
- -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
- -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
- read_result <-
- -- 1. Check if the interface is already loaded into the EPS by some other
- -- part of the compiler.
- lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
- Just iface -> return (M.Succeeded iface)
- Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
- case read_result of
- M.Succeeded iface -> do
- -- Computer information about this node
- let node_deps = ifaceDeps (mi_deps iface)
- edges = map mkFixedEdge node_deps
- node = ModuleNode edges (ModuleNodeFixed key loc)
- foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
- -- Ignore any failure, we might try to read a .hi-boot file for
- -- example, even if there is not one.
- M.Failed {} ->
- return done
-
- loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedNodeKey _ done (Left key) = do
- loopFixedImports [key] done
- loopFixedNodeKey home_uid done (Right uid) = do
- -- Set active unit so that looking loopUnit finds the correct
- -- -package flags in the unit state.
- let hsc_env' = hscSetActiveUnitId home_uid hsc_env
- return $ loopUnit hsc_env' done [uid]
-
- mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
- mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
- mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
-
- ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
- ifaceDeps deps =
- [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
- | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
- ] ++
- [ Right (tcImportLevel lvl, uid)
- | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
- ]
-
- -- Like loopImports, but we already know exactly which module we are looking for.
- loopFixedImports :: [ModNodeKeyWithUid]
- -> M.Map NodeKey ModuleGraphNode
- -> IO (M.Map NodeKey ModuleGraphNode)
- loopFixedImports [] done = pure done
- loopFixedImports (key:keys) done = do
- let nk = NodeKey_Module key
- case M.lookup nk done of
- Just {} -> loopFixedImports keys done
- Nothing -> do
- read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
- case read_result of
- InstalledFound loc -> do
- done' <- loopFixedModule key loc done
- loopFixedImports keys done'
- _otherwise ->
- -- If the finder fails, just keep going, there will be another
- -- error later.
- loopFixedImports keys done
-
- downsweepSummarise :: HscEnv
- -> HomeUnit
- -> M.Map (UnitId, FilePath) ModSummary
- -> IsBootInterface
- -> Located ModuleName
- -> PkgQual
- -> Maybe (StringBuffer, UTCTime)
- -> [ModuleName]
- -> IO SummariseResult
- downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =
- case mode of
- DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
- DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
-
-
- -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
- -- a new module by doing this.
- loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
- -- Work list: process these modules
- -> M.Map NodeKey ModuleGraphNode
- -> DownsweepCache
- -- Visited set; the range is a list because
- -- the roots can have the same module names
- -- if allow_dup_roots is True
- -> IO ([ModuleNodeEdge],
- M.Map NodeKey ModuleGraphNode, DownsweepCache)
- -- The result is the completed NodeMap
- loopImports [] done summarised = return ([], done, summarised)
- loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
- | Just summs <- M.lookup cache_key summarised
- = case summs of
- [Right ms] -> do
- let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
- (rest, summarised', done') <- loopImports ss done summarised
- return (nk: rest, summarised', done')
- [Left _err] ->
- loopImports ss done summarised
- _errs -> do
- loopImports ss done summarised
- | otherwise
- = do
- mb_s <- downsweepSummarise hsc_env home_unit old_summaries
- is_boot wanted_mod mb_pkg
- Nothing excl_mods
- case mb_s of
- NotThere -> loopImports ss done summarised
- External uid -> do
- -- Pass an updated hsc_env to loopUnit, as each unit might
- -- have a different visible package database.
- let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
- let done' = loopUnit hsc_env' done [uid]
- (other_deps, done'', summarised') <- loopImports ss done' summarised
- return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
- FoundInstantiation iud -> do
- (other_deps, done', summarised') <- loopImports ss done summarised
- return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
- FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
- FoundHome s -> do
- (done', summarised') <-
- loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
- (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
-
- -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
- return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
- where
- cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
- home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
- wanted_mod = L loc mod
-
- loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
- loopUnit _ cache [] = cache
- loopUnit lcl_hsc_env cache (u:uxs) = do
- let nk = (NodeKey_ExternalUnit u)
- case Map.lookup nk cache of
- Just {} -> loopUnit lcl_hsc_env cache uxs
- Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
- Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
- Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
+
+calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+calcDeps ms =
+ -- Add a dependency on the HsBoot file if it exists
+ -- This gets passed to the loopImports function which just ignores it if it
+ -- can't be found.
+ [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
+ [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]
+
+
+type DownsweepM a = ReaderT DownsweepEnv IO a
+data DownsweepEnv = DownsweepEnv {
+ downsweep_hsc_env :: HscEnv
+ , _downsweep_mode :: DownsweepMode
+ , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary
+ , _downsweep_excl_mods :: [ModuleName]
+}
+
+runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a
+runDownsweepM env act = runReaderT act env
+
+
+loopInstantiations :: [(UnitId, InstantiatedUnit)]
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopInstantiations [] done = pure done
+loopInstantiations ((home_uid, iud) :xs) done = do
+ hsc_env <- asks downsweep_hsc_env
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
+ done' = loopUnit hsc_env' done [instUnitInstanceOf iud]
+ payload = InstantiationNode home_uid iud
+ loopInstantiations xs (M.insert (mkNodeKey payload) payload done')
+
+
+-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
+loopSummaries :: [ModSummary]
+ -> (M.Map NodeKey ModuleGraphNode,
+ DownsweepCache)
+ -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)
+loopSummaries [] done = pure done
+loopSummaries (ms:next) (done, summarised)
+ | Just {} <- M.lookup k done
+ = loopSummaries next (done, summarised)
+ -- Didn't work out what the imports mean yet, now do that.
+ | otherwise = do
+ (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised
+ -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
+ (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
+ loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')
+ where
+ k = NodeKey_Module (msKey ms)
+
+ hs_file_for_boot
+ | HsBootFile <- ms_hsc_src ms
+ = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
+ | otherwise
+ = Nothing
+
+loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is
+
+loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)
+loopModuleNodeInfo mod_node_info (done, summarised) = do
+ case mod_node_info of
+ ModuleNodeCompile ms -> do
+ loopSummaries [ms] (done, summarised)
+ ModuleNodeFixed mod ml -> do
+ done' <- loopFixedModule mod ml done
+ return (done', summarised)
+
+-- NB: loopFixedModule does not take a downsweep cache, because if you
+-- ever reach a Fixed node, everything under that also must be fixed.
+loopFixedModule :: ModNodeKeyWithUid -> ModLocation
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedModule key loc done = do
+ let nk = NodeKey_Module key
+ hsc_env <- asks downsweep_hsc_env
+ case M.lookup nk done of
+ Just {} -> return done
+ Nothing -> do
+ -- MP: TODO, we should just read the dependency info from the interface rather than either
+ -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
+ -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
+ read_result <- liftIO $
+ -- 1. Check if the interface is already loaded into the EPS by some other
+ -- part of the compiler.
+ lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case
+ Just iface -> return (M.Succeeded iface)
+ Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)
+ case read_result of
+ M.Succeeded iface -> do
+ -- Computer information about this node
+ let node_deps = ifaceDeps (mi_deps iface)
+ edges = map mkFixedEdge node_deps
+ node = ModuleNode edges (ModuleNodeFixed key loc)
+ foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)
+ -- Ignore any failure, we might try to read a .hi-boot file for
+ -- example, even if there is not one.
+ M.Failed {} ->
+ return done
+
+loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedNodeKey _ done (Left key) = do
+ loopFixedImports [key] done
+loopFixedNodeKey home_uid done (Right uid) = do
+ -- Set active unit so that looking loopUnit finds the correct
+ -- -package flags in the unit state.
+ hsc_env <- asks downsweep_hsc_env
+ let hsc_env' = hscSetActiveUnitId home_uid hsc_env
+ return $ loopUnit hsc_env' done [uid]
+
+mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge
+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)
+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)
+
+ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]
+ifaceDeps deps =
+ [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)
+ | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)
+ ] ++
+ [ Right (tcImportLevel lvl, uid)
+ | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)
+ ]
+
+-- Like loopImports, but we already know exactly which module we are looking for.
+loopFixedImports :: [ModNodeKeyWithUid]
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepM (M.Map NodeKey ModuleGraphNode)
+loopFixedImports [] done = pure done
+loopFixedImports (key:keys) done = do
+ let nk = NodeKey_Module key
+ hsc_env <- asks downsweep_hsc_env
+ case M.lookup nk done of
+ Just {} -> loopFixedImports keys done
+ Nothing -> do
+ read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)
+ case read_result of
+ InstalledFound loc -> do
+ done' <- loopFixedModule key loc done
+ loopFixedImports keys done'
+ _otherwise ->
+ -- If the finder fails, just keep going, there will be another
+ -- error later.
+ loopFixedImports keys done
+
+downsweepSummarise :: HomeUnit
+ -> IsBootInterface
+ -> Located ModuleName
+ -> PkgQual
+ -> Maybe (StringBuffer, UTCTime)
+ -> DownsweepM SummariseResult
+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do
+ DownsweepEnv hsc_env mode old_summaries excl_mods <- ask
+ case mode of
+ DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods
+ DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods
+
+
+-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
+-- a new module by doing this.
+loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ -- Work list: process these modules
+ -> M.Map NodeKey ModuleGraphNode
+ -> DownsweepCache
+ -- Visited set; the range is a list because
+ -- the roots can have the same module names
+ -- if allow_dup_roots is True
+ -> DownsweepM ([ModuleNodeEdge],
+ M.Map NodeKey ModuleGraphNode, DownsweepCache)
+ -- The result is the completed NodeMap
+loopImports [] done summarised = return ([], done, summarised)
+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised
+ | Just summs <- M.lookup cache_key summarised
+ = case summs of
+ [Right ms] -> do
+ let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))
+ (rest, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, summarised', done')
+ [Left _err] ->
+ loopImports ss done summarised
+ _errs -> do
+ loopImports ss done summarised
+ | otherwise
+ = do
+ hsc_env <- asks downsweep_hsc_env
+ let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
+ mb_s <- downsweepSummarise home_unit
+ is_boot wanted_mod mb_pkg
+ Nothing
+ case mb_s of
+ NotThere -> loopImports ss done summarised
+ External uid -> do
+ -- Pass an updated hsc_env to loopUnit, as each unit might
+ -- have a different visible package database.
+ let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env
+ let done' = loopUnit hsc_env' done [uid]
+ (other_deps, done'', summarised') <- loopImports ss done' summarised
+ return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')
+ FoundInstantiation iud -> do
+ (other_deps, done', summarised') <- loopImports ss done summarised
+ return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')
+ FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
+ FoundHome s -> do
+ (done', summarised') <-
+ loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)
+ (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'
+
+ -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
+ return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)
+ where
+ cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
+ GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
+ wanted_mod = L loc mod
+
+loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode
+loopUnit _ cache [] = cache
+loopUnit lcl_hsc_env cache (u:uxs) = do
+ let nk = (NodeKey_ExternalUnit u)
+ case Map.lookup nk cache of
+ Just {} -> loopUnit lcl_hsc_env cache uxs
+ Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of
+ Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs
+ Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)
multiRootsErr :: [ModuleNodeInfo] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -164,6 +164,7 @@ import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
+import GHC.Driver.Downsweep
import GHC.Data.FastString
import GHC.Data.Maybe
@@ -2077,12 +2078,25 @@ was added for External Core which faced a similar issue.
*********************************************************
-}
+-- This function is essentially a single-level downsweep
+-- for an interactive module. There is no source file, so we create a fixed node.
+withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a
+withInteractiveModuleNode hsc_env thing_inside = do
+ mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env)
+ updTopEnv (\env -> env { hsc_mod_graph = mg }) thing_inside
+
+
+
+
+
+
runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive hsc_env thing_inside
= initTcInteractive hsc_env $ withTcPlugins hsc_env $
withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
+ withInteractiveModuleNode hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))
=====================================
compiler/GHC/Unit/Module/Graph.hs
=====================================
@@ -101,6 +101,9 @@ module GHC.Unit.Module.Graph
-- time it's called.
, filterToposortToModules
, moduleGraphNodesZero
+ , StageSummaryNode
+ , stageSummaryNodeSummary
+ , stageSummaryNodeKey
, mkStageDeps
-- * Keys into the 'ModuleGraph'
@@ -930,6 +933,9 @@ stageSummaryNodeSummary = node_payload
-- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage
-- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages.
-- * Otherwise, an imported module is just needed at the normal stage.
+--
+-- * A module using TemplateHaskellQuotes required at C stage is also required at R
+-- stage.
moduleGraphNodesStages ::
[ModuleGraphNode]
-> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
@@ -945,7 +951,7 @@ moduleGraphNodesStages summaries =
normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode
normal_case ((m@(ModuleNode nks ms), s)) =
DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $
- concatMap (classifyDeps ms s) nks
+ selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks
normal_case (m, s) =
DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m)
@@ -955,6 +961,16 @@ moduleGraphNodesStages summaries =
isTemplateHaskellQuotesMS :: ModSummary -> Bool
isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms)
+ -- Accounting for persistence within a module.
+ -- If a module is required @ C and it persists an idenfifier, it's also required
+ -- at R.
+ selfEdges (ModuleNodeCompile ms) s self_key
+ | not (isExplicitStageMS ms)
+ && (isTemplateHaskellQuotesMS ms
+ || isTemplateHaskellOrQQNonBoot ms)
+ = [(self_key, s') | s' <- onlyFutureStages s]
+ selfEdges _ _ _ = []
+
-- Case 1. No implicit stage persistnce is enabled
classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k)
| isExplicitStageMS ms = case il of
@@ -966,7 +982,7 @@ moduleGraphNodesStages summaries =
| not (isExplicitStageMS ms)
, not (isTemplateHaskellOrQQNonBoot ms)
, isTemplateHaskellQuotesMS ms
- = [(k, s') | s' <- futureStages s]
+ = [(k, s') | s' <- nowAndFutureStages s]
-- Case 2b. Template haskell is enabled, with implicit stage persistence
classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k)
| isTemplateHaskellOrQQNonBoot ms
@@ -977,7 +993,7 @@ moduleGraphNodesStages summaries =
numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]
- numbered_summaries = zip (([(s, l) | s <- summaries, l <- [CompileStage, RunStage]])) [0..]
+ numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..]
lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode
lookup_node key = Map.lookup key node_map
=====================================
compiler/GHC/Unit/Module/Stage.hs
=====================================
@@ -1,6 +1,7 @@
module GHC.Unit.Module.Stage ( ModuleStage(..)
, allStages
- , futureStages
+ , nowAndFutureStages
+ , onlyFutureStages
, minStage
, maxStage
, zeroStage
@@ -56,8 +57,12 @@ data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded)
allStages :: [ModuleStage]
allStages = [minBound .. maxBound]
-futureStages :: ModuleStage -> [ModuleStage]
-futureStages cur_st = [cur_st .. ]
+nowAndFutureStages :: ModuleStage -> [ModuleStage]
+nowAndFutureStages cur_st = [cur_st .. ]
+
+onlyFutureStages :: ModuleStage -> [ModuleStage]
+onlyFutureStages cur_st | cur_st == maxBound = []
+onlyFutureStages cur_st = [succ cur_st .. ]
minStage :: ModuleStage
minStage = minBound
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -2928,6 +2928,7 @@ iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude
= unLoc (ideclName d1) == unLoc (ideclName d2)
&& ideclAs d1 == ideclAs d2
+ && convImportLevel (ideclLevelSpec d1) == convImportLevel (ideclLevelSpec d2)
&& (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))
&& (ideclImportList d1 `hidingSubsumes` ideclImportList d2)
where
=====================================
testsuite/tests/splice-imports/SI30.stdout
=====================================
@@ -0,0 +1 @@
+2
=====================================
testsuite/tests/splice-imports/SI31.script
=====================================
@@ -0,0 +1,2 @@
+-- Failure, since explicit level imports is on
+$(id [| () |])
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/SI31.stderr
=====================================
@@ -0,0 +1,7 @@
+<interactive>:2:3: error: [GHC-28914]
+ • Level error: ‘id’ is bound at level 0 but used at level -1
+ Hint: quoting [| id |] or an enclosing expression
+ would allow the quotation to be used at an earlier level
+ From imports {imported from ‘Prelude’}
+ • In the untyped splice: $(id [| () |])
+
=====================================
testsuite/tests/splice-imports/SI32.script
=====================================
@@ -0,0 +1,5 @@
+-- Success case with explicit level imports
+import Language.Haskell.TH
+import splice Data.Function (id)
+
+$(id [| () |])
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/SI32.stdout
=====================================
@@ -0,0 +1 @@
+()
=====================================
testsuite/tests/splice-imports/SI33.script
=====================================
@@ -0,0 +1,8 @@
+-- Test using both normal and splice level imports with Template Haskell
+import Language.Haskell.TH
+-- Using two imports here tests the iiSubsumes function
+import splice Data.Function (id)
+import Data.Function (id)
+
+-- Use the splice-level 'id' in the splice and normal-level 'on' in the quote
+$(id [| id () |])
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/SI33.stdout
=====================================
@@ -0,0 +1 @@
+()
=====================================
testsuite/tests/splice-imports/SI34.hs
=====================================
@@ -0,0 +1,11 @@
+module SI34 where
+
+-- Compiling SI34 @ R, requires SI34M2 @ R, which requires SI34M1 @ R,
+-- but NOT SI34M1 @ C or SI34M2 @ C due to ImplicitStagePersistence + TemplateHaskellQuotes
+import SI34M2
+
+-- Uses the MkT constructor indirectly through SI34M2.makeMkT
+foo = makeMkT 42
+
+-- Uses the wrapper type from SI34M2
+bar = wrapT (makeMkT 100)
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/SI34.stderr
=====================================
@@ -0,0 +1,3 @@
+[1 of 3] Compiling SI34M1 ( SI34M1.hs, nothing )
+[2 of 3] Compiling SI34M2 ( SI34M2.hs, nothing )
+[3 of 3] Compiling SI34 ( SI34.hs, nothing )
=====================================
testsuite/tests/splice-imports/SI34M1.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE ImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module SI34M1 where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data T = MkT Int
+ deriving Show
+
+instance Lift T where
+ lift (MkT n) = [| MkT $(lift n) |]
+ liftTyped (MkT n) = [|| MkT $$(liftTyped n) ||]
=====================================
testsuite/tests/splice-imports/SI34M2.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE ImplicitStagePersistence #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module SI34M2 (
+ makeMkT,
+ TWrapper(..),
+ wrapT
+) where
+
+import SI34M1
+import Language.Haskell.TH.Syntax
+
+-- A wrapper for T
+data TWrapper = WrapT T
+ deriving Show
+
+-- Create a MkT with the given Int
+makeMkT :: Int -> T
+makeMkT = MkT
+
+-- Wrap a T in a TWrapper
+wrapT :: T -> TWrapper
+wrapT = WrapT
+
+-- Quote functions for TWrapper
+instance Lift TWrapper where
+ lift (WrapT t) = [| WrapT $(lift t) |]
+ liftTyped (WrapT t) = [|| WrapT $$(liftTyped t) ||]
=====================================
testsuite/tests/splice-imports/SI35.hs
=====================================
@@ -0,0 +1,79 @@
+{-# LANGUAGE RecordWildCards #-}
+module Main where
+
+import GHC
+import GHC.Driver.Session
+import GHC.Driver.Monad
+import GHC.Driver.Make (load', summariseFile)
+import GHC.Unit.Module.Graph
+import GHC.Unit.Module.ModSummary
+import GHC.Unit.Types
+import GHC.Unit.Module.ModIface
+import GHC.Unit.Module
+import GHC.Unit.Module.ModNodeKey
+import GHC.Types.SourceFile
+import System.Environment
+import Control.Monad (void, when)
+import Data.Maybe (fromJust)
+import Control.Exception (ExceptionWithContext(..), SomeException)
+import Control.Monad.Catch (handle, throwM)
+import Control.Exception.Context
+import GHC.Utils.Outputable
+import GHC.Unit.Home
+import GHC.Driver.Env
+import Data.List (sort)
+import GHC.Driver.MakeFile
+import GHC.Data.Maybe
+import GHC.Unit.Module.Stage
+import GHC.Data.Graph.Directed.Reachability
+import GHC.Utils.Trace
+import GHC.Unit.Module.Graph
+
+main :: IO ()
+main = do
+ [libdir] <- getArgs
+ runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) ->
+ liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do
+
+ -- Set up session
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ hsc_env <- getSession
+ setSession $ hscSetActiveUnitId mainUnitId hsc_env
+
+ -- Get ModSummary for our test module
+ msA <- getModSummaryFromTarget "SI35A.hs"
+
+ -- Define NodeKey
+ let keyA = NodeKey_Module (msKey msA)
+ edgeA = mkNormalEdge keyA
+
+ -- Define ModuleNodeInfo
+ let infoA_compile = ModuleNodeCompile msA
+
+ -- Define the complete node
+ let nodeA_compile = ModuleNode [] infoA_compile
+
+ -- This test checks that a module required at compile stage invokes a
+ -- depedency on the runstage of itself when using TemplateHaskellQuotes.
+
+ -- This is hard to test with a normal compiler invocation as GHC does not
+ -- not distinguish very easily these two stages.
+ let (ri, to_node) = mkStageDeps [nodeA_compile]
+ let reachable = allReachable ri (expectJust $ to_node (keyA, CompileStage))
+ let reachable_nodes = map stageSummaryNodeSummary reachable
+
+ if (keyA, RunStage) `elem` reachable_nodes
+ then return ()
+ else do
+ liftIO $ putStrLn "Test failed -- (keyA, RunStage) not reachable"
+ pprTraceM "reachable_nodes" (ppr reachable_nodes)
+ pprTraceM "reachable" (ppr (reachabilityIndexMembers ri))
+
+ where
+ -- Helper to get ModSummary from a target file
+ getModSummaryFromTarget :: FilePath -> Ghc ModSummary
+ getModSummaryFromTarget file = do
+ hsc_env <- getSession
+ Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing
+ return ms
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/SI35A.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module SI35A where
+
+-- Define a type for use in Template Haskell
+data T = MkT Int
+
+-- Helper function to construct a T
+mkT :: Int -> T
+mkT = MkT
+
+-- A function that creates a quoted expression using T
+quotedT :: Int -> Q Exp
+quotedT n = [| mkT n |]
+
+-- Another quoted expression function
+quotedAdd :: Q Exp
+quotedAdd = [| \x y -> x + y :: Int |]
+
+-- Show instance
+instance Show T where
+ show (MkT n) = "MkT " ++ show n
\ No newline at end of file
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -36,3 +36,12 @@ test('SI27', normal, compile_fail, [''])
test('SI28', normal, compile_fail, [''])
test('SI29', normal, compile_fail, [''])
test('SI30', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports")], ghci_script, ['SI30.script'])
+test('SI31', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI31.script'])
+test('SI32', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI32.script'])
+test('SI33', [only_ways(['ghci']), extra_hc_opts("-XExplicitLevelImports -XTemplateHaskell")], ghci_script, ['SI33.script'])
+test('SI34', [extra_files(["SI34M1.hs", "SI34M2.hs"])], multimod_compile, ['SI34', '-fno-code'])
+test('SI35',
+ [extra_run_opts(f'"{config.libdir}"'),
+ extra_files(['SI35A.hs'])],
+ compile_and_run,
+ ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e44ea99aafb6f70c4618bfb3c2c565…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
410f1a57 by Simon Peyton Jones at 2025-04-23T15:55:03+01:00
Wibbles
- - - - -
8 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -3679,10 +3679,10 @@ lintVarOcc :: InVar -> LintM OutType
lintVarOcc v_occ
= do { in_var_env <- getInVarEnv
; case lookupVarEnv in_var_env v_occ of
- Nothing | isGlobalId v_occ -> return (idType v_occ)
- | otherwise -> failWithL (text "The" <+> ppr (whatItIs v_occ)
- <+> quotes (ppr v_occ)
- <+> text "is out of scope")
+ Nothing | isGlobalVar v_occ -> return (idType v_occ)
+ | otherwise -> failWithL (text "The" <+> ppr (whatItIs v_occ)
+ <+> quotes (ppr v_occ)
+ <+> text "is out of scope")
Just (in_bndr, out_bndr) -> do { checkBndrOccCompatibility in_bndr v_occ
; return (varType out_bndr) } }
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1137,15 +1137,18 @@ occAnalRec :: OccEnv -> TopLevelFlag
occAnalRec !_ lvl
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
(WUD body_uds binds)
- | isDeadOcc occ -- Check for dead code: see Note [Dead code]
- = WUD body_uds binds
-
+ -- Currently we don't gather occ-info for tyvars,
+ -- so we never discard dead bindings -- Need to fix this
| isTyVar bndr
= let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
!(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
!bndr' = tagged_bndr
in WUD (body_uds `andUDs` rhs_uds')
(NonRec bndr' rhs' : binds)
+
+ | isDeadOcc occ -- Check for dead code: see Note [Dead code]
+ = WUD body_uds binds
+
| otherwise
= let (bndr', mb_join) = tagNonRecBinder lvl occ bndr
!(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -392,7 +392,8 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and sy
where
do_tcv is v = Endo do_it
where
- do_it acc | v `elemVarSet` is = acc
+ do_it acc | isGlobalVar v = acc
+ | v `elemVarSet` is = acc
| v `elemVarSet` acc = acc
| otherwise = acc `extendVarSet` v
@@ -448,7 +449,8 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView
do_covar is v = Endo do_it
where
- do_it acc | v `elemVarSet` is = acc
+ do_it acc | isGlobalVar v = acc
+ | v `elemVarSet` is = acc
| v `elemVarSet` acc = acc
| otherwise = appEndo (deep_cv_ty (varType v)) $
acc `extendVarSet` v
@@ -599,9 +601,9 @@ tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys
tyCoFVsOfType :: Type -> FV
-- See Note [Free variables of types]
tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set)
- | not (f v) = (acc_list, acc_set)
+ | not (f v) = (acc_list, acc_set)
| v `elemVarSet` bound_vars = (acc_list, acc_set)
- | v `elemVarSet` acc_set = (acc_list, acc_set)
+ | v `elemVarSet` acc_set = (acc_list, acc_set)
| otherwise = tyCoFVsOfType (tyVarKind v) f
emptyVarSet -- See Note [Closing over free variable kinds]
(v:acc_list, extendVarSet acc_set v)
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -2070,7 +2070,7 @@ freeNamesIfAppArgs IA_Nil = emptyNameSet
freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceFreeTyVar {}) = emptyNameSet
freeNamesIfType (IfaceTyVar {}) = emptyNameSet
-freeNamesIfType (IfaceExtTyVar {}) = emptyNameSet
+freeNamesIfType (IfaceExtTyVar n) = unitNameSet n
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
=====================================
compiler/GHC/Iface/Tidy.hs
=====================================
@@ -761,20 +761,20 @@ chooseExternalVars opts mod binds imp_id_rules
search [] unfold_env occ_env = return (unfold_env, occ_env)
- search ((idocc,referrer) : rest) unfold_env occ_env
- | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
+ search ((var_occ,referrer) : rest) unfold_env occ_env
+ | var_occ `elemVarEnv` unfold_env = search rest unfold_env occ_env
| otherwise = do
- (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
+ (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env var_occ
let
(new_ids, show_unfold) = addExternal opts refined_id
- -- 'idocc' is an *occurrence*, but we need to see the
+ -- 'var_occ' is an *occurrence*, but we need to see the
-- unfolding in the *definition*; so look up in binder_set
- refined_id = case lookupVarSet binder_set idocc of
+ refined_id = case lookupVarSet binder_set var_occ of
Just id -> id
- Nothing -> warnPprTrace True "chooseExternalVars" (ppr idocc) idocc
+ Nothing -> warnPprTrace True "chooseExternalVars" (ppr var_occ) var_occ
- unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
+ unfold_env' = extendVarEnv unfold_env var_occ (name',show_unfold)
referrer' | isExportedId refined_id = refined_id
| otherwise = referrer
--
@@ -808,7 +808,7 @@ addExternal opts id
= (new_needed_ids, show_unfold)
where
- new_needed_ids = bndrFvsInOrder show_unfold id
+ new_needed_ids = idBndrFvsInOrder show_unfold id
idinfo = idInfo id
unfolding = realUnfoldingInfo idinfo
show_unfold = show_unfolding unfolding
@@ -921,9 +921,9 @@ the free variables in the order that they are encountered.
See Note [Choosing external Ids]
-}
-bndrFvsInOrder :: Bool -> Id -> [Var]
-bndrFvsInOrder show_unfold id
--- Gather the free vars of the RULES and unfolding of a binder
+idBndrFvsInOrder :: Bool -> Id -> [Var]
+idBndrFvsInOrder show_unfold id
+-- Gather the free vars of the type, RULES and unfolding of an Id binder
-- We always get the free vars of a *stable* unfolding, but
-- for a *vanilla* one (VanillaSrc), the flag controls what happens:
-- True <=> get fvs of even a *vanilla* unfolding
@@ -933,107 +933,18 @@ bndrFvsInOrder show_unfold id
-- For top-level bindings (call from addExternal, via bndrFvsInOrder)
-- we say "True" if we are exposing that unfolding
= fvVarList $
- go_unf (realUnfoldingInfo idinfo) `unionFV`
- rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo))
+ tyCoFVsOfType (idType id) `unionFV`
+ unf_fvs `unionFV`
+ rules_fvs
where
idinfo = idInfo id
- go_unf :: Unfolding -> FV
- go_unf unf | show_unfold = unfoldingFVs unf
- | otherwise = emptyFV
+ unf_fvs :: FV
+ unf_fvs | show_unfold = unfoldingFVs (realUnfoldingInfo idinfo)
+ | otherwise = emptyFV
--- = run (dffvLetBndr show_unfold id)
-
-{-
-run :: DFFV () -> [Id]
-run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
- ((_,ids),_) -> ids
-
-newtype DFFV a
- = DFFV (VarSet -- Envt: non-top-level things that are in scope
- -- we don't want to record these as free vars
- -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far
- -> ((VarSet,[Var]),a)) -- Output state
- deriving (Functor)
-
-instance Applicative DFFV where
- pure a = DFFV $ \_ st -> (st, a)
- (<*>) = ap
-
-instance Monad DFFV where
- (DFFV m) >>= k = DFFV $ \env st ->
- case m env st of
- (st',a) -> case k a of
- DFFV f -> f env st'
-
-extendScope :: Var -> DFFV a -> DFFV a
-extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
-
-extendScopeList :: [Var] -> DFFV a -> DFFV a
-extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
-
-insert :: Var -> DFFV ()
-insert v = DFFV $ \ env (set, ids) ->
- let keep_me = isLocalId v &&
- not (v `elemVarSet` env) &&
- not (v `elemVarSet` set)
- in if keep_me
- then ((extendVarSet set v, v:ids), ())
- else ((set, ids), ())
-
-
-dffvExpr :: CoreExpr -> DFFV ()
-dffvExpr (Var v) = insert v
-dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2
-dffvExpr (Lam v e) = extendScope v (dffvExpr e)
-dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e
-dffvExpr (Tick _other e) = dffvExpr e
-dffvExpr (Cast e _) = dffvExpr e
-dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
-dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $
- (mapM_ dffvBind prs >> dffvExpr e)
-dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
-dffvExpr _other = return ()
-
-dffvAlt :: CoreAlt -> DFFV ()
-dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r)
-
-dffvBind :: (Var, CoreExpr) -> DFFV ()
-dffvBind(x,r)
- | not (isId x) = dffvExpr r
- | otherwise = dffvLetBndr False x >> dffvExpr r
- -- Pass False because we are doing the RHS right here
- -- If you say True you'll get *exponential* behaviour!
-
-dffvLetBndr :: Bool -> Id -> DFFV ()
--- Gather the free vars of the RULES and unfolding of a binder
--- We always get the free vars of a *stable* unfolding, but
--- for a *vanilla* one (VanillaSrc), the flag controls what happens:
--- True <=> get fvs of even a *vanilla* unfolding
--- False <=> ignore a VanillaSrc
--- For nested bindings (call from dffvBind) we always say "False" because
--- we are taking the fvs of the RHS anyway
--- For top-level bindings (call from addExternal, via bndrFvsInOrder)
--- we say "True" if we are exposing that unfolding
-dffvLetBndr vanilla_unfold id
- = do { go_unf (realUnfoldingInfo idinfo)
- ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
- where
- idinfo = idInfo id
-
- go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
- | isStableSource src = dffvExpr rhs
- | vanilla_unfold = dffvExpr rhs
- | otherwise = return ()
-
- go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
- = extendScopeList bndrs $ mapM_ dffvExpr args
- go_unf _ = return ()
-
- go_rule (BuiltinRule {}) = return ()
- go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
- = extendScopeList bndrs (dffvExpr rhs)
--}
+ rules_fvs :: FV
+ rules_fvs = rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo))
{-
************************************************************************
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -761,8 +761,8 @@ substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
substIfaceType env ty
= go ty
where
- go ty@(IfaceFreeTyVar tv) = ty
- go ty@(IfaceExtTyVar tv) = ty
+ go ty@(IfaceFreeTyVar {}) = ty
+ go ty@(IfaceExtTyVar {}) = ty
go (IfaceTyVar tv) = substIfaceTyVar env tv
go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2)
@@ -1148,8 +1148,8 @@ ppr_ty ctxt_prec ty
| not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty
ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType
ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
-ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
-ppr_ty _ (IfaceExtTyVar tyvar) = ppr tyvar
+ppr_ty _ (IfaceTyVar tyvar) = text "{free}" <> ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
+ppr_ty _ (IfaceExtTyVar tyvar) = text "{ext}" <> ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
@@ -2373,9 +2373,8 @@ putIfaceType bh (IfaceTupleTy s i tys)
= do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
putIfaceType bh (IfaceLitTy n)
= do { putByte bh 9; put_ bh n }
-putIfaceType bh (IfaceExtTyVar tv) = do
- putByte bh 10
- put_ bh tv
+putIfaceType bh (IfaceExtTyVar tv)
+ = do { putByte bh 10; put_ bh tv }
-- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'.
--
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -726,7 +726,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
tc_iface_decl _ _ (IfaceTv {ifName = name, ifTvKind = if_kind, ifTvUnf = if_type })
= do { kind <- tcIfaceType if_kind
- ; unf_ty <- tcIfaceType if_type
+ ; unf_ty <- forkM (text "IfaceTv" <+> ppr name) $ tcIfaceType if_type
; return (ATyVar (mkTyVarWithUnfolding name kind unf_ty)) }
tc_iface_decl _ _ (IfaceData {ifName = tc_name,
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -62,7 +62,7 @@ module GHC.Types.Var (
-- ** Predicates
isId, isTyVar, isTcTyVar,
isCoVar, isNonCoVarId, isTyCoVar,
- isLocalVar, isGlobalVar,
+ isLocalVar, isGlobalVar, isGlobalTyVar,
isLocalId, isLocalId_maybe, isGlobalId, isExportedId,
mustHaveLocalBinding,
@@ -1297,6 +1297,12 @@ isGlobalVar (Id { idScope = LocalId {} }) = False
isGlobalVar (TyVar { varName = n }) = isExternalName n
isGlobalVar (TcTyVar {}) = False
+isGlobalTyVar :: HasDebugCallStack => Var -> Bool
+-- A TyVar with an External Name is always from another module
+isGlobalTyVar (TyVar { varName = n }) = isExternalName n
+isGlobalTyVar (TcTyVar {}) = False
+isGlobalTyVar v = pprPanic "isGlobalTyVar" (ppr v)
+
-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's
-- that must have a binding in this module. The converse
-- is not quite right: there are some global 'Id's that must have
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410f1a5749a695dacd15bfd1d05a941…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410f1a5749a695dacd15bfd1d05a941…
You're receiving this email because of your account on gitlab.haskell.org.
1
0