summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2021-02-04 23:20:25 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-26 19:00:07 -0400
commit599efd90d54a01802b1285c0e357738e4d0bdb3a (patch)
tree2f6468fe8caabebd85d4a84d805bf04f7de1cd77
parent872a9444df4d38cd5dc0fbb7a249d89596e73ea2 (diff)
downloadhaskell-599efd90d54a01802b1285c0e357738e4d0bdb3a.tar.gz
Refactor FinderCache
-rw-r--r--compiler/GHC.hs19
-rw-r--r--compiler/GHC/Driver/Backpack.hs9
-rw-r--r--compiler/GHC/Driver/Env/Types.hs2
-rw-r--r--compiler/GHC/Driver/Main.hs3
-rw-r--r--compiler/GHC/Driver/Make.hs18
-rw-r--r--compiler/GHC/Driver/MakeFile.hs39
-rw-r--r--compiler/GHC/Driver/Pipeline.hs5
-rw-r--r--compiler/GHC/HsToCore/Usage.hs11
-rw-r--r--compiler/GHC/Iface/Env.hs11
-rw-r--r--compiler/GHC/Iface/Load.hs158
-rw-r--r--compiler/GHC/Iface/Recomp.hs151
-rw-r--r--compiler/GHC/IfaceToCore.hs9
-rw-r--r--compiler/GHC/Linker/Loader.hs5
-rw-r--r--compiler/GHC/Runtime/Loader.hs7
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs5
-rw-r--r--compiler/GHC/Tc/Plugin.hs6
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs45
-rw-r--r--compiler/GHC/Unit/Finder.hs238
-rw-r--r--compiler/GHC/Unit/Finder/Types.hs8
-rw-r--r--ghc/GHCi/UI.hs6
-rw-r--r--ghc/Main.hs10
-rw-r--r--testsuite/tests/ghc-api/downsweep/OldModLocation.hs3
22 files changed, 447 insertions, 321 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 0c55bfbea1..4e554e58ce 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -990,7 +990,9 @@ guessTarget str Nothing
-- you should also unload the current program (set targets to empty,
-- followed by load).
workingDirectoryChanged :: GhcMonad m => m ()
-workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
+workingDirectoryChanged = do
+ hsc_env <- getSession
+ liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)
-- %************************************************************************
@@ -1652,11 +1654,13 @@ showRichTokenStream ts = go startLoc ts ""
-- using the algorithm that is used for an @import@ declaration.
findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
- let dflags = hsc_dflags hsc_env
- home_unit = hsc_home_unit hsc_env
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
case maybe_pkg of
Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do
- res <- findImportedModule hsc_env mod_name maybe_pkg
+ res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
@@ -1665,7 +1669,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
case home of
Just m -> return m
Nothing -> liftIO $ do
- res <- findImportedModule hsc_env mod_name maybe_pkg
+ res <- findImportedModule fc units home_unit dflags mod_name maybe_pkg
case res of
Found loc m | not (isHomeModule home_unit m) -> return m
| otherwise -> modNotLoadedError dflags m loc
@@ -1691,7 +1695,10 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do
case home of
Just m -> return m
Nothing -> liftIO $ do
- res <- findExposedPackageModule hsc_env mod_name Nothing
+ let fc = hsc_FC hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ res <- findExposedPackageModule fc units dflags mod_name Nothing
case res of
Found _ m -> return m
err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 07c56bb36a..a174a5be95 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -737,6 +737,7 @@ summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
summariseRequirement pn mod_name = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
+ let home_unit = hsc_home_unit hsc_env
let PackageName pn_fs = pn
location <- liftIO $ mkHomeModLocation2 dflags mod_name
@@ -748,7 +749,8 @@ summariseRequirement pn mod_name = do
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+ let fc = hsc_FC hsc_env
+ mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
@@ -861,7 +863,10 @@ hsModuleToModSummary pn hsc_src modname
(implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports
-- So that Finder can find it, even though it doesn't exist...
- this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
+ this_mod <- liftIO $ do
+ let home_unit = hsc_home_unit hsc_env
+ let fc = hsc_FC hsc_env
+ addHomeModuleToFinder fc home_unit modname location
return $ ExtendedModSummary
{ emsModSummary =
ModSummary {
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index 4465d206dd..abf19a0afa 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -106,7 +106,7 @@ data HscEnv
-- ^ Global Name cache so that each Name gets a single Unique.
-- Also track the origin of the Names.
- hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
+ hsc_FC :: {-# UNPACK #-} !FinderCache,
-- ^ The cached result of performing finding in the file system
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index f3ae968a6f..e77ce02c65 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -168,6 +168,7 @@ import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Unit
+import GHC.Unit.Finder
import GHC.Unit.External
import GHC.Unit.State
import GHC.Unit.Module.ModDetails
@@ -245,7 +246,7 @@ newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
nc_var <- initNameCache us knownKeyNames
- fc_var <- newIORef emptyInstalledModuleEnv
+ fc_var <- initFinderCache
logger <- initLogger
tmpfs <- initTmpFs
-- FIXME: it's sad that we have so many "unitialized" fields filled with
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 0d30d81de9..734608b471 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -220,7 +220,7 @@ depanalPartial excluded_mods allow_dup_roots = do
-- source files may have appeared in the home package that shadow
-- external package modules, so we have to discard the existing
-- cached finder data.
- liftIO $ flushFinderCaches hsc_env
+ liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)
mod_summariesE <- liftIO $ downsweep
hsc_env (mgExtendedModSummaries old_graph)
@@ -2549,7 +2549,10 @@ summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
- mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location
+ mod <- liftIO $ do
+ let home_unit = hsc_home_unit hsc_env
+ let fc = hsc_FC hsc_env
+ addHomeModuleToFinder fc home_unit pi_mod_name location
liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
{ nms_src_fn = src_fn
@@ -2600,7 +2603,10 @@ checkSummaryTimestamp
-- and it was likely flushed in depanal. This is not technically
-- needed when we're called from sumariseModule but it shouldn't
-- hurt.
- _ <- addHomeModuleToFinder hsc_env
+ _ <- do
+ let home_unit = hsc_home_unit hsc_env
+ let fc = hsc_FC hsc_env
+ addHomeModuleToFinder fc home_unit
(moduleName (ms_mod old_summary)) location
hi_timestamp <- maybeGetIfaceDate dflags location
@@ -2661,8 +2667,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
| otherwise = find_it
where
- dflags = hsc_dflags hsc_env
+ dflags = hsc_dflags hsc_env
home_unit = hsc_home_unit hsc_env
+ fc = hsc_FC hsc_env
+ units = hsc_units hsc_env
check_timestamp old_summary location src_fn =
checkSummaryTimestamp
@@ -2671,7 +2679,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
old_summary location
find_it = do
- found <- findImportedModule hsc_env wanted_mod Nothing
+ found <- findImportedModule fc units home_unit dflags wanted_mod Nothing
case found of
Found location mod
| isJust (ml_hs_file location) ->
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index f71b2e17b9..b6572bcb5b 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -286,24 +286,27 @@ findDependency :: HscEnv
-> IsBootInterface -- Source import
-> Bool -- Record dependency on package modules
-> IO (Maybe FilePath) -- Interface file
-findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
- = do { -- Find the module; this will be fast because
- -- we've done it once during downsweep
- r <- findImportedModule hsc_env imp pkg
- ; case r of
- Found loc _
- -- Home package: just depend on the .hi or hi-boot file
- | isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
-
- -- Not in this package: we don't need a dependency
- | otherwise
- -> return Nothing
-
- fail ->
- throwOneError $ mkPlainMsgEnvelope srcloc $
- cannotFindModule hsc_env imp fail
- }
+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ -- Find the module; this will be fast because
+ -- we've done it once during downsweep
+ r <- findImportedModule fc units home_unit dflags imp pkg
+ case r of
+ Found loc _
+ -- Home package: just depend on the .hi or hi-boot file
+ | isJust (ml_hs_file loc) || include_pkg_deps
+ -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+
+ -- Not in this package: we don't need a dependency
+ | otherwise
+ -> return Nothing
+
+ fail ->
+ throwOneError $ mkPlainMsgEnvelope srcloc $
+ cannotFindModule hsc_env imp fail
-----------------------------
writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index bf9fbe8405..6d945f6ff1 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -1303,7 +1303,10 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn
PipeState{hsc_env=hsc_env'} <- getPipeState
-- Tell the finder cache about this module
- mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
+ mod <- liftIO $ do
+ let home_unit = hsc_home_unit hsc_env'
+ let fc = hsc_FC hsc_env'
+ addHomeModuleToFinder fc home_unit mod_name location
-- Make the ModSummary to hand to hscMain
let
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index 3a0c27faac..a0fadacb89 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -213,7 +213,11 @@ mkPluginUsage hsc_env pluginModule
(ppr pNm)
_ -> mapM hashFile (nub files)
_ -> do
- foundM <- findPluginModule hsc_env pNm
+ let fc = hsc_FC hsc_env
+ let units = hsc_units hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ foundM <- findPluginModule fc units home_unit dflags pNm
case foundM of
-- The plugin was built locally: look up the object file containing
-- the `plugin` binder, and all object files belong to modules that are
@@ -225,6 +229,9 @@ mkPluginUsage hsc_env pluginModule
_ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
where
dflags = hsc_dflags hsc_env
+ fc = hsc_FC hsc_env
+ home_unit = hsc_home_unit hsc_env
+ units = hsc_units hsc_env
platform = targetPlatform dflags
pkgs = hsc_units hsc_env
pNm = moduleName $ mi_module pluginModule
@@ -235,7 +242,7 @@ mkPluginUsage hsc_env pluginModule
-- Lookup object file for a plugin dependency,
-- from the same package as the plugin.
lookupObjectFile nm = do
- foundM <- findImportedModule hsc_env nm Nothing
+ foundM <- findImportedModule fc units home_unit dflags nm Nothing
case foundM of
Found ml m
| moduleUnit m == pPkg -> Just <$> hashFile (ml_obj_file ml)
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
index ad62a6232b..2290b5f8bf 100644
--- a/compiler/GHC/Iface/Env.hs
+++ b/compiler/GHC/Iface/Env.hs
@@ -15,7 +15,7 @@ module GHC.Iface.Env (
ifaceExportNames,
- trace_if, trace_hi_diffs, -- FIXME: temporary
+ trace_if, trace_hi_diffs,
-- Name-cache stuff
allocateGlobalBinder,
@@ -48,6 +48,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Utils.Error
+import GHC.Utils.Logger
import Data.List ( partition )
import Control.Monad
@@ -276,10 +277,10 @@ newIfaceNames occs
; return [ mkInternalName uniq occ noSrcSpan
| (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
-trace_if :: DynFlags -> SDoc -> IO ()
+trace_if :: Logger -> DynFlags -> SDoc -> IO ()
{-# INLINE trace_if #-}
-trace_if dflags doc = when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags doc
+trace_if logger dflags doc = when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags doc
-trace_hi_diffs :: DynFlags -> SDoc -> IO ()
+trace_hi_diffs :: Logger -> DynFlags -> SDoc -> IO ()
{-# INLINE trace_hi_diffs #-}
-trace_hi_diffs dflags doc = when (dopt Opt_D_dump_hi_diffs dflags) $ putMsg dflags doc
+trace_hi_diffs logger dflags doc = when (dopt Opt_D_dump_hi_diffs dflags) $ putMsg logger dflags doc
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 6e9ac0b548..534af94d28 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -169,7 +169,8 @@ importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)
importDecl name
= ASSERT( not (isWiredInName name) )
do { dflags <- getDynFlags
- ; liftIO $ trace_if dflags nd_doc
+ ; logger <- getLogger
+ ; liftIO $ trace_if logger dflags nd_doc
-- Load the interface, which should populate the PTE
; mb_iface <- ASSERT2( isExternalName name, ppr name )
@@ -244,7 +245,8 @@ checkWiredInTyCon tc
| otherwise
= do { mod <- getModule
; dflags <- getDynFlags
- ; liftIO $ trace_if dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
+ ; logger <- getLogger
+ ; liftIO $ trace_if logger dflags (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
; ASSERT( isExternalName tc_name )
when (mod /= nameModule tc_name)
(initIfaceTcRn (loadWiredInHomeIface tc_name))
@@ -315,12 +317,16 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
-- and create a ModLocation. If successful, loadIface will read the
-- interface; it will call the Finder again, but the ModLocation will be
-- cached from the first search.
- = do { hsc_env <- getTopEnv
- ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
- ; case res of
+ = do hsc_env <- getTopEnv
+ let fc = hsc_FC hsc_env
+ let dflags = hsc_dflags hsc_env
+ let units = hsc_units hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ res <- liftIO $ findImportedModule fc units home_unit dflags mod maybe_pkg
+ case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
-- TODO: Make sure this error message is good
- err -> return (Failed (cannotFindModule hsc_env mod err)) }
+ err -> return (Failed (cannotFindModule hsc_env mod err))
-- | Load interface directly for a fully qualified 'Module'. (This is a fairly
-- rare operation, but in particular it is used to load orphan modules
@@ -445,8 +451,9 @@ loadInterface doc_str mod from
(eps,hpt) <- getEpsAndHpt
; gbl_env <- getGblEnv
; dflags <- getDynFlags
+ ; logger <- getLogger
- ; liftIO $ trace_if dflags (text "Considering whether to load" <+> ppr mod <+> ppr from)
+ ; liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+> ppr from)
-- Check whether we have the interface already
; hsc_env <- getTopEnv
@@ -681,20 +688,25 @@ computeInterface
-> Module
-> IO (MaybeErr SDoc (ModIface, FilePath))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
- MASSERT( not (isHoleModule mod0) )
- let home_unit = hsc_home_unit hsc_env
- case getModuleInstantiation mod0 of
- (imod, Just indef) | isHomeUnitIndefinite home_unit -> do
- r <- findAndReadIface hsc_env doc_str imod mod0 hi_boot_file
- case r of
- Succeeded (iface0, path) -> do
- r <- rnModIface hsc_env (instUnitInsts (moduleUnit indef))
- Nothing iface0
- case r of
- Right x -> return (Succeeded (x, path))
- Left errs -> throwIO . mkSrcErr $ errs
- Failed err -> return (Failed err)
- (mod, _) -> findAndReadIface hsc_env doc_str mod mod0 hi_boot_file
+ MASSERT( not (isHoleModule mod0) )
+ let name_cache = hsc_NC hsc_env
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
+ let find_iface m = findAndReadIface logger name_cache fc hooks units home_unit dflags doc_str
+ m mod0 hi_boot_file
+ case getModuleInstantiation mod0 of
+ (imod, Just indef) | isHomeUnitIndefinite home_unit ->
+ find_iface imod >>= \case
+ Succeeded (iface0, path) ->
+ rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
+ Right x -> return (Succeeded (x, path))
+ Left errs -> throwIO . mkSrcErr $ errs
+ Failed err -> return (Failed err)
+ (mod, _) -> find_iface mod
-- | Compute the signatures which must be compiled in order to
-- load the interface for a 'Module'. The output of this function
@@ -714,8 +726,9 @@ moduleFreeHolesPrecise doc_str mod
case getModuleInstantiation mod of
(imod, Just indef) -> do
dflags <- getDynFlags
+ logger <- getLogger
let insts = instUnitInsts (moduleUnit indef)
- liftIO $ trace_if dflags (text "Considering whether to load" <+> ppr mod <+>
+ liftIO $ trace_if logger dflags (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
(eps, hpt) <- getEpsAndHpt
case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of
@@ -731,7 +744,16 @@ moduleFreeHolesPrecise doc_str mod
_otherwise -> Nothing
readAndCache imod insts = do
hsc_env <- getTopEnv
- mb_iface <- liftIO $ findAndReadIface hsc_env (text "moduleFreeHolesPrecise" <+> doc_str) imod mod NotBoot
+ let nc = hsc_NC hsc_env
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
+ mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags
+ (text "moduleFreeHolesPrecise" <+> doc_str)
+ imod mod NotBoot
case mb_iface of
Succeeded (iface, _) -> do
let ifhs = mi_free_holes iface
@@ -820,32 +842,25 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
See #8320.
-}
-findAndReadIface :: HscEnv
- -> SDoc
- -- The unique identifier of the on-disk module we're
- -- looking for
- -> InstalledModule
- -- The *actual* module we're looking for. We use
- -- this to check the consistency of the requirements
- -- of the module we read out.
- -> Module
- -> IsBootInterface -- True <=> Look for a .hi-boot file
- -- False <=> Look for .hi file
- -> IO (MaybeErr SDoc (ModIface, FilePath))
- -- Nothing <=> file not found, or unreadable, or illegible
- -- Just x <=> successfully found and parsed
-
- -- It *doesn't* add an error to the monad, because
- -- sometimes it's ok to fail... see notes with loadInterface
-findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
- let dflags = hsc_dflags hsc_env
- let home_unit = hsc_home_unit hsc_env
- let unit_env = hsc_unit_env hsc_env
- let profile = targetProfile dflags
- let name_cache = hsc_NC hsc_env
- let unit_state = hsc_units hsc_env
+findAndReadIface
+ :: Logger
+ -> NameCache
+ -> FinderCache
+ -> Hooks
+ -> UnitState
+ -> HomeUnit
+ -> DynFlags
+ -> SDoc -- ^ Reason for loading the iface (used for tracing)
+ -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for
+ -> Module -- ^ The *actual* module we're looking for. We use
+ -- this to check the consistency of the requirements of the
+ -- module we read out.
+ -> IsBootInterface -- ^ Looking for .hi-boot or .hi file
+ -> IO (MaybeErr SDoc (ModIface, FilePath))
+findAndReadIface logger name_cache fc hooks unit_state home_unit dflags doc_str mod wanted_mod hi_boot_file = do
+ let profile = targetProfile dflags
- trace_if dflags (sep [hsep [text "Reading",
+ trace_if logger dflags (sep [hsep [text "Reading",
if hi_boot_file == IsBoot
then text "[boot]"
else Outputable.empty,
@@ -858,14 +873,13 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
-- TODO: make this check a function
if mod `installedModuleEq` gHC_PRIM
then do
- hooks <- getHooks
let iface = case ghcPrimIfaceHook hooks of
Nothing -> ghcPrimIface
Just h -> h
return (Succeeded (iface, "<built in interface for GHC.Prim>"))
else do
-- Look for the file
- mb_found <- liftIO (findExactModule hsc_env mod)
+ mb_found <- liftIO (findExactModule fc dflags unit_state home_unit mod)
case mb_found of
InstalledFound loc mod -> do
-- Found file, so read it
@@ -875,53 +889,54 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do
- r <- read_file name_cache unit_state dflags wanted_mod file_path
+ r <- read_file logger name_cache unit_state dflags wanted_mod file_path
case r of
Failed _
-> return ()
Succeeded (iface,fp)
- -> load_dynamic_too_maybe name_cache unit_state
+ -> load_dynamic_too_maybe logger name_cache unit_state
dflags wanted_mod
hi_boot_file iface fp
return r
err -> do
- trace_if dflags (text "...not found")
+ trace_if logger dflags (text "...not found")
return $ Failed $ cannotFindInterface
- unit_env
+ unit_state
+ home_unit
profile
- (may_show_locations (hsc_dflags hsc_env))
+ (may_show_locations dflags)
(moduleName mod)
err
-- | Check if we need to try the dynamic interface for -dynamic-too
-load_dynamic_too_maybe :: NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO ()
-load_dynamic_too_maybe name_cache unit_state dflags wanted_mod is_boot iface file_path
+load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO ()
+load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod is_boot iface file_path
-- Indefinite interfaces are ALWAYS non-dynamic.
| not (moduleIsDefinite (mi_module iface)) = return ()
| otherwise = dynamicTooState dflags >>= \case
DT_Dont -> return ()
DT_Failed -> return ()
- DT_Dyn -> load_dynamic_too name_cache unit_state dflags wanted_mod is_boot iface file_path
- DT_OK -> load_dynamic_too name_cache unit_state (setDynamicNow dflags) wanted_mod is_boot iface file_path
+ DT_Dyn -> load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path
+ DT_OK -> load_dynamic_too logger name_cache unit_state (setDynamicNow dflags) wanted_mod is_boot iface file_path
-load_dynamic_too :: NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO ()
-load_dynamic_too name_cache unit_state dflags wanted_mod is_boot iface file_path = do
+load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> IsBootInterface -> ModIface -> FilePath -> IO ()
+load_dynamic_too logger name_cache unit_state dflags wanted_mod is_boot iface file_path = do
let dynFilePath = addBootSuffix_maybe is_boot
$ replaceExtension file_path (hiSuf dflags)
- read_file name_cache unit_state dflags wanted_mod dynFilePath >>= \case
+ read_file logger name_cache unit_state dflags wanted_mod dynFilePath >>= \case
Succeeded (dynIface, _)
| mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)
-> return ()
| otherwise ->
- do trace_if dflags (text "Dynamic hash doesn't match")
+ do trace_if logger dflags (text "Dynamic hash doesn't match")
setDynamicTooFailed dflags
Failed err ->
- do trace_if dflags (text "Failed to load dynamic interface file:" $$ err)
+ do trace_if logger dflags (text "Failed to load dynamic interface file:" $$ err)
setDynamicTooFailed dflags
-read_file :: NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))
-read_file name_cache unit_state dflags wanted_mod file_path = do
- trace_if dflags (text "readIFace" <+> text file_path)
+read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))
+read_file logger name_cache unit_state dflags wanted_mod file_path = do
+ trace_if logger dflags (text "readIFace" <+> text file_path)
-- Figure out what is recorded in mi_module. If this is
-- a fully definite interface, it'll match exactly, but
@@ -1282,25 +1297,24 @@ homeModError mod location
-- -----------------------------------------------------------------------------
-- Error messages
-cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc
+cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc
cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
(sLit "Ambiguous interface for")
cantFindInstalledErr
:: PtrString
-> PtrString
- -> UnitEnv
+ -> UnitState
+ -> HomeUnit
-> Profile
-> ([FilePath] -> SDoc)
-> ModuleName
-> InstalledFindResult
-> SDoc
-cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result
+cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result
= ptext cannot_find <+> quotes (ppr mod_name)
$$ more_info
where
- home_unit = ue_home_unit unit_env
- unit_state = ue_units unit_env
build_tag = waysBuildTag (profileWays profile)
more_info
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index e211f221ab..409cb712f2 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -41,6 +41,7 @@ import GHC.Utils.Misc as Utils hiding ( eqListBy )
import GHC.Utils.Binary
import GHC.Utils.Fingerprint
import GHC.Utils.Exception
+import GHC.Utils.Logger
import GHC.Types.Annotations
import GHC.Types.Name
@@ -157,10 +158,11 @@ check_old_iface
check_old_iface hsc_env mod_summary src_modified maybe_iface
= let dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
getIface =
case maybe_iface of
Just _ -> do
- trace_if dflags (text "We already have the old interface for" <+>
+ trace_if logger dflags (text "We already have the old interface for" <+>
ppr (ms_mod mod_summary))
return maybe_iface
Nothing -> loadIface
@@ -171,20 +173,20 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
read_result <- readIface dflags ncu (ms_mod mod_summary) iface_path
case read_result of
Failed err -> do
- trace_if dflags (text "FYI: cannot read old interface file:" $$ nest 4 err)
- trace_hi_diffs dflags (text "Old interface file was invalid:" $$ nest 4 err)
+ trace_if logger dflags (text "FYI: cannot read old interface file:" $$ nest 4 err)
+ trace_hi_diffs logger dflags (text "Old interface file was invalid:" $$ nest 4 err)
return Nothing
Succeeded iface -> do
- trace_if dflags (text "Read the interface file" <+> text iface_path)
+ trace_if logger dflags (text "Read the interface file" <+> text iface_path)
return $ Just iface
src_changed
- | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+ | gopt Opt_ForceRecomp dflags = True
| SourceModified <- src_modified = True
| otherwise = False
in do
when src_changed $
- liftIO $ trace_hi_diffs dflags (nest 4 $ text "Source file changed or recompilation check turned off")
+ liftIO $ trace_hi_diffs logger dflags (nest 4 $ text "Source file changed or recompilation check turned off")
case src_changed of
-- If the source has changed and we're in interactive mode,
@@ -227,7 +229,7 @@ checkVersions :: HscEnv
-> ModIface -- Old interface
-> IfG (RecompileRequired, Maybe ModIface)
checkVersions hsc_env mod_summary iface
- = do { liftIO $ trace_hi_diffs dflags
+ = do { liftIO $ trace_hi_diffs logger dflags
(text "Considering whether compilation is required for" <+>
ppr (mi_module iface) <> colon)
@@ -245,7 +247,7 @@ checkVersions hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- liftIO $ checkMergedSignatures hsc_env mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
- ; recomp <- liftIO $ checkHsig hsc_env mod_summary iface
+ ; recomp <- liftIO $ checkHsig logger home_unit dflags mod_summary iface
; if recompileRequired recomp then return (recomp, Nothing) else do {
; recomp <- pure (checkHie dflags mod_summary)
; if recompileRequired recomp then return (recomp, Nothing) else do {
@@ -274,6 +276,7 @@ checkVersions hsc_env mod_summary iface
; return (recomp, Just iface)
}}}}}}}}}}
where
+ logger = hsc_logger hsc_env
dflags = hsc_dflags hsc_env
home_unit = hsc_home_unit hsc_env
-- This is a bit of a hack really
@@ -352,15 +355,13 @@ pluginRecompileToRecompileRequired old_fp new_fp pr
-- | Check if an hsig file needs recompilation because its
-- implementing module has changed.
-checkHsig :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
-checkHsig hsc_env mod_summary iface = do
- let home_unit = hsc_home_unit hsc_env
- dflags = hsc_dflags hsc_env
- outer_mod = ms_mod mod_summary
+checkHsig :: Logger -> HomeUnit -> DynFlags -> ModSummary -> ModIface -> IO RecompileRequired
+checkHsig logger home_unit dflags mod_summary iface = do
+ let outer_mod = ms_mod mod_summary
inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
MASSERT( isHomeModule home_unit outer_mod )
case inner_mod == mi_semantic_module iface of
- True -> up_to_date dflags (text "implementing module unchanged")
+ True -> up_to_date logger dflags (text "implementing module unchanged")
False -> return (RecompBecause "implementing module changed")
-- | Check if @.hie@ file is out of date or missing.
@@ -382,11 +383,12 @@ checkHie dflags mod_summary =
checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
checkFlagHash hsc_env iface = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let old_hash = mi_flag_hash (mi_final_exts iface)
new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally
case old_hash == new_hash of
- True -> up_to_date dflags (text "Module flags unchanged")
- False -> out_of_date_hash dflags "flags changed"
+ True -> up_to_date logger dflags (text "Module flags unchanged")
+ False -> out_of_date_hash logger dflags "flags changed"
(text " Module flags have changed")
old_hash new_hash
@@ -394,15 +396,16 @@ checkFlagHash hsc_env iface = do
checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
checkOptimHash hsc_env iface = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let old_hash = mi_opt_hash (mi_final_exts iface)
new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
- -> up_to_date dflags (text "Optimisation flags unchanged")
+ -> up_to_date logger dflags (text "Optimisation flags unchanged")
| gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
- -> up_to_date dflags (text "Optimisation flags changed; ignoring")
+ -> up_to_date logger dflags (text "Optimisation flags changed; ignoring")
| otherwise
- -> out_of_date_hash dflags "Optimisation flags changed"
+ -> out_of_date_hash logger dflags "Optimisation flags changed"
(text " Optimisation flags have changed")
old_hash new_hash
@@ -410,15 +413,16 @@ checkOptimHash hsc_env iface = do
checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
checkHpcHash hsc_env iface = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let old_hash = mi_hpc_hash (mi_final_exts iface)
new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)
putNameLiterally
if | old_hash == new_hash
- -> up_to_date dflags (text "HPC flags unchanged")
+ -> up_to_date logger dflags (text "HPC flags unchanged")
| gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
- -> up_to_date dflags (text "HPC flags changed; ignoring")
+ -> up_to_date logger dflags (text "HPC flags changed; ignoring")
| otherwise
- -> out_of_date_hash dflags "HPC flags changed"
+ -> out_of_date_hash logger dflags "HPC flags changed"
(text " HPC flags have changed")
old_hash new_hash
@@ -427,6 +431,7 @@ checkHpcHash hsc_env iface = do
checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
checkMergedSignatures hsc_env mod_summary iface = do
let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
let unit_state = hsc_units hsc_env
let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
new_merged = case Map.lookup (ms_mod_name mod_summary)
@@ -434,7 +439,7 @@ checkMergedSignatures hsc_env mod_summary iface = do
Nothing -> []
Just r -> sort $ map (instModuleToModule unit_state) r
if old_merged == new_merged
- then up_to_date dflags (text "signatures to merge in unchanged" $$ ppr new_merged)
+ then up_to_date logger dflags (text "signatures to merge in unchanged" $$ ppr new_merged)
else return (RecompBecause "signatures to merge in changed")
-- If the direct imports of this module are resolved to targets that
@@ -470,20 +475,23 @@ checkDependencies hsc_env summary iface
checkIfAllOldHomeDependenciesAreSeen seen_home_deps
_ -> return recomp]
where
- dflags = hsc_dflags hsc_env
+ dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
+ fc = hsc_FC hsc_env
+ home_unit = hsc_home_unit hsc_env
+ units = hsc_units hsc_env
prev_dep_mods = dep_mods (mi_deps iface)
prev_dep_plgn = dep_plgins (mi_deps iface)
prev_dep_pkgs = dep_pkgs (mi_deps iface)
- home_unit = hsc_home_unit hsc_env
dep_missing (mb_pkg, L _ mod) = do
- find_res <- findImportedModule hsc_env mod (mb_pkg)
+ find_res <- findImportedModule fc units home_unit dflags mod (mb_pkg)
let reason = moduleNameString mod ++ " changed"
case find_res of
Found _ mod
| isHomeUnit home_unit pkg
-> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn
- then do trace_hi_diffs dflags $
+ then do trace_hi_diffs logger dflags $
text "imported module " <> quotes (ppr mod) <>
text " not among previous dependencies"
return (RecompBecause reason)
@@ -491,7 +499,7 @@ checkDependencies hsc_env summary iface
return UpToDate
| otherwise
-> if toUnitId pkg `notElem` (map fst prev_dep_pkgs)
- then do trace_hi_diffs dflags $
+ then do trace_hi_diffs logger dflags $
text "imported module " <> quotes (ppr mod) <>
text " is from package " <> quotes (ppr pkg) <>
text ", which is not among previous dependencies"
@@ -517,13 +525,13 @@ checkDependencies hsc_env summary iface
if not (isOldHomeDeps mname)
then return (UpToDate, [])
else do
- mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> liftIO $ do
+ mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do
let mnames = mname:(map gwib_mod $ filter ((== NotBoot) . gwib_isBoot) $
dep_mods $ mi_deps imported_iface)
case find (not . isOldHomeDeps) mnames of
Nothing -> return (UpToDate, mnames)
Just new_dep_mname -> do
- trace_hi_diffs dflags $
+ trace_hi_diffs logger dflags $
text "imported home module " <> quotes (ppr mod) <>
text " has a new dependency " <> quotes (ppr new_dep_mname)
return (RecompBecause reason, [])
@@ -548,7 +556,7 @@ checkDependencies hsc_env summary iface
if not (null unseen_old_deps)
then do
let missing_dep = Set.elemAt 0 unseen_old_deps
- trace_hi_diffs dflags $
+ trace_hi_diffs logger dflags $
text "missing old home dependency " <> quotes (ppr missing_dep)
return $ RecompBecause "missing old dependency"
else return UpToDate
@@ -560,18 +568,19 @@ needInterface mod continue
mb_recomp <- getFromModIface
"need version info for"
mod
- (liftIO . continue)
+ continue
case mb_recomp of
Nothing -> return MustCompile
Just recomp -> return recomp
-getFromModIface :: String -> Module -> (ModIface -> IfG a)
+getFromModIface :: String -> Module -> (ModIface -> IO a)
-> IfG (Maybe a)
getFromModIface doc_msg mod getter
= do -- Load the imported interface if possible
dflags <- getDynFlags
+ logger <- getLogger
let doc_str = sep [text doc_msg, ppr mod]
- liftIO $ trace_hi_diffs dflags (text "Checking innterface for module" <+> ppr mod)
+ liftIO $ trace_hi_diffs logger dflags (text "Checking interface for module" <+> ppr mod)
mb_iface <- loadInterface doc_str mod ImportBySystem
-- Load the interface, but don't complain on failure;
@@ -579,13 +588,13 @@ getFromModIface doc_msg mod getter
case mb_iface of
Failed _ -> do
- liftIO $ trace_hi_diffs dflags (sep [text "Couldn't load interface for module", ppr mod])
+ liftIO $ trace_hi_diffs logger dflags (sep [text "Couldn't load interface for module", ppr mod])
return Nothing
-- Couldn't find or parse a module mentioned in the
-- old interface file. Don't complain: it might
-- just be that the current module doesn't need that
-- import and it's been deleted
- Succeeded iface -> Just <$> getter iface
+ Succeeded iface -> Just <$> liftIO (getter iface)
-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
@@ -595,9 +604,10 @@ checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash } = do
dflags <- getDynFlags
+ logger <- getLogger
needInterface mod $ \iface -> do
let reason = moduleNameString (moduleName mod) ++ " changed"
- checkModuleFingerprint dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
+ checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
-- We only track the ABI hash of package modules, rather than
-- individual entity usages, so if the ABI hash changes we must
-- recompile. This is safe but may entail more recompilation when
@@ -605,9 +615,10 @@ checkModUsage _this_pkg UsagePackageModule{
checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
dflags <- getDynFlags
+ logger <- getLogger
needInterface mod $ \iface -> do
let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
- checkModuleFingerprint dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
+ checkModuleFingerprint logger dflags reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
checkModUsage this_pkg UsageHomeModule{
usg_mod_name = mod_name,
@@ -617,6 +628,7 @@ checkModUsage this_pkg UsageHomeModule{
= do
let mod = mkModule this_pkg mod_name
dflags <- getDynFlags
+ logger <- getLogger
needInterface mod $ \iface -> do
let
new_mod_hash = mi_mod_hash (mi_final_exts iface)
@@ -627,20 +639,20 @@ checkModUsage this_pkg UsageHomeModule{
liftIO $ do
-- CHECK MODULE
- recompile <- checkModuleFingerprint dflags reason old_mod_hash new_mod_hash
+ recompile <- checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash
if not (recompileRequired recompile)
then return UpToDate
else
-- CHECK EXPORT LIST
- checkMaybeHash dflags reason maybe_old_export_hash new_export_hash
+ checkMaybeHash logger dflags reason maybe_old_export_hash new_export_hash
(text " Export list changed") $ do
-- CHECK ITEMS ONE BY ONE
- recompile <- checkList [ checkEntityUsage dflags reason new_decl_hash u
+ recompile <- checkList [ checkEntityUsage logger dflags reason new_decl_hash u
| u <- old_decl_hash]
if recompileRequired recompile
then return recompile -- This one failed, so just bail out now
- else up_to_date dflags (text " Great! The bits I use are up to date")
+ else up_to_date logger dflags (text " Great! The bits I use are up to date")
checkModUsage _this_pkg UsageFile{ usg_file_path = file,
@@ -661,52 +673,65 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file,
#endif
------------------------
-checkModuleFingerprint :: DynFlags -> String -> Fingerprint -> Fingerprint
- -> IO RecompileRequired
-checkModuleFingerprint dflags reason old_mod_hash new_mod_hash
+checkModuleFingerprint
+ :: Logger
+ -> DynFlags
+ -> String
+ -> Fingerprint
+ -> Fingerprint
+ -> IO RecompileRequired
+checkModuleFingerprint logger dflags reason old_mod_hash new_mod_hash
| new_mod_hash == old_mod_hash
- = up_to_date dflags (text "Module fingerprint unchanged")
+ = up_to_date logger dflags (text "Module fingerprint unchanged")
| otherwise
- = out_of_date_hash dflags reason (text " Module fingerprint has changed")
+ = out_of_date_hash logger dflags reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
------------------------
-checkMaybeHash :: DynFlags -> String -> Maybe Fingerprint -> Fingerprint -> SDoc
- -> IO RecompileRequired -> IO RecompileRequired
-checkMaybeHash dflags reason maybe_old_hash new_hash doc continue
+checkMaybeHash
+ :: Logger
+ -> DynFlags
+ -> String
+ -> Maybe Fingerprint
+ -> Fingerprint
+ -> SDoc
+ -> IO RecompileRequired
+ -> IO RecompileRequired
+checkMaybeHash logger dflags reason maybe_old_hash new_hash doc continue
| Just hash <- maybe_old_hash, hash /= new_hash
- = out_of_date_hash dflags reason doc hash new_hash
+ = out_of_date_hash logger dflags reason doc hash new_hash
| otherwise
= continue
------------------------
-checkEntityUsage :: DynFlags
+checkEntityUsage :: Logger
+ -> DynFlags
-> String
-> (OccName -> Maybe (OccName, Fingerprint))
-> (OccName, Fingerprint)
-> IO RecompileRequired
-checkEntityUsage dflags reason new_hash (name,old_hash) = do
+checkEntityUsage logger dflags reason new_hash (name,old_hash) = do
case new_hash name of
-- We used it before, but it ain't there now
- Nothing -> out_of_date dflags reason (sep [text "No longer exported:", ppr name])
+ Nothing -> out_of_date logger dflags reason (sep [text "No longer exported:", ppr name])
-- It's there, but is it up to date?
Just (_, new_hash)
| new_hash == old_hash
- -> do trace_hi_diffs dflags (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
+ -> do trace_hi_diffs logger dflags (text " Up to date" <+> ppr name <+> parens (ppr new_hash))
return UpToDate
| otherwise
- -> out_of_date_hash dflags reason (text " Out of date:" <+> ppr name) old_hash new_hash
+ -> out_of_date_hash logger dflags reason (text " Out of date:" <+> ppr name) old_hash new_hash
-up_to_date :: DynFlags -> SDoc -> IO RecompileRequired
-up_to_date dflags msg = trace_hi_diffs dflags msg >> return UpToDate
+up_to_date :: Logger -> DynFlags -> SDoc -> IO RecompileRequired
+up_to_date logger dflags msg = trace_hi_diffs logger dflags msg >> return UpToDate
-out_of_date :: DynFlags -> String -> SDoc -> IO RecompileRequired
-out_of_date dflags reason msg = trace_hi_diffs dflags msg >> return (RecompBecause reason)
+out_of_date :: Logger -> DynFlags -> String -> SDoc -> IO RecompileRequired
+out_of_date logger dflags reason msg = trace_hi_diffs logger dflags msg >> return (RecompBecause reason)
-out_of_date_hash :: DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
-out_of_date_hash dflags reason msg old_hash new_hash
- = out_of_date dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+out_of_date_hash :: Logger -> DynFlags -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
+out_of_date_hash logger dflags reason msg old_hash new_hash
+ = out_of_date logger dflags reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
----------------------
checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 6f4ea646a0..cf0584615b 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -544,7 +544,14 @@ tcHiBootIface hsc_src mod
-- to check consistency against, rather than just when we notice
-- that an hi-boot is necessary due to a circular import.
{ hsc_env <- getTopEnv
- ; read_result <- liftIO $ findAndReadIface hsc_env
+ ; let nc = hsc_NC hsc_env
+ ; let fc = hsc_FC hsc_env
+ ; let home_unit = hsc_home_unit hsc_env
+ ; let units = hsc_units hsc_env
+ ; let dflags = hsc_dflags hsc_env
+ ; let logger = hsc_logger hsc_env
+ ; let hooks = hsc_hooks hsc_env
+ ; read_result <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags
need (fst (getModuleInstantiation mod)) mod
IsBoot -- Hi-boot file
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index ebc5a0b0c0..15e31a37cc 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -731,7 +731,10 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
- mb_stuff <- findHomeModule hsc_env mod_name
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ mb_stuff <- findHomeModule fc home_unit dflags mod_name
case mb_stuff of
Found loc mod -> found loc mod
_ -> no_obj mod_name
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 4f8f1e6edb..a1386b7937 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -259,8 +259,12 @@ lessUnsafeCoerce logger dflags context what = do
lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
-> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
+ let dflags = hsc_dflags hsc_env
+ let fc = hsc_FC hsc_env
+ let units = hsc_units hsc_env
+ let home_unit = hsc_home_unit hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
- found_module <- findPluginModule hsc_env mod_name
+ found_module <- findPluginModule fc units home_unit dflags mod_name
case found_module of
Found _ mod -> do
-- Find the exports of the module
@@ -282,7 +286,6 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err
where
- dflags = hsc_dflags hsc_env
doc = text "contains a name used in an invocation of lookupRdrNameInModule"
wrongTyThingError :: Name -> TyThing -> SDoc
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 9c84c98ff9..c5b300b8ba 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1192,7 +1192,10 @@ instance TH.Quasi TcM where
qAddCorePlugin plugin = do
hsc_env <- getTopEnv
- r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ r <- liftIO $ findHomeModule fc home_unit dflags (mkModuleName plugin)
let err = hang
(text "addCorePlugin: invalid plugin module "
<+> text (show plugin)
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
index fc1b607dbe..b4d4fc5ad2 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ b/compiler/GHC/Tc/Plugin.hs
@@ -98,7 +98,11 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult
findImportedModule mod_name mb_pkg = do
hsc_env <- getTopEnv
- tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ tcPluginIO $ Finder.findImportedModule fc units home_unit dflags mod_name mb_pkg
lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 544f38c908..2dc485fb84 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -312,12 +312,16 @@ implicitRequirements' :: HscEnv
implicitRequirements' hsc_env normal_imports
= fmap concat $
forM normal_imports $ \(mb_pkg, L _ imp) -> do
- found <- findImportedModule hsc_env imp mb_pkg
+ found <- findImportedModule fc units home_unit dflags imp mb_pkg
case found of
Found _ mod | not (isHomeModule home_unit mod) ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
- where home_unit = hsc_home_unit hsc_env
+ where
+ fc = hsc_FC hsc_env
+ home_unit = hsc_home_unit hsc_env
+ units = hsc_units hsc_env
+ dflags = hsc_dflags hsc_env
-- | Like @implicitRequirements'@, but returns either the module name, if it is
-- a free hole, or the instantiated unit the imported module is from, so that
@@ -329,11 +333,16 @@ implicitRequirementsShallow
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
where
+ fc = hsc_FC hsc_env
+ home_unit = hsc_home_unit hsc_env
+ units = hsc_units hsc_env
+ dflags = hsc_dflags hsc_env
+
go acc [] = pure acc
go (accL, accR) ((mb_pkg, L _ imp):imports) = do
- found <- findImportedModule hsc_env imp mb_pkg
+ found <- findImportedModule fc units home_unit dflags imp mb_pkg
let acc' = case found of
- Found _ mod | not (isHomeModule (hsc_home_unit hsc_env) mod) ->
+ Found _ mod | not (isHomeModule home_unit mod) ->
case moduleUnit mod of
HoleUnit -> (moduleName mod : accL, accR)
RealUnit _ -> (accL, accR)
@@ -561,11 +570,15 @@ mergeSignatures
tcg_env <- getGblEnv
let outer_mod = tcg_mod tcg_env
- inner_mod = tcg_semantic_mod tcg_env
- mod_name = moduleName (tcg_mod tcg_env)
- unit_state = hsc_units hsc_env
- home_unit = hsc_home_unit hsc_env
- dflags = hsc_dflags hsc_env
+ let inner_mod = tcg_semantic_mod tcg_env
+ let mod_name = moduleName (tcg_mod tcg_env)
+ let unit_state = hsc_units hsc_env
+ let fc = hsc_FC hsc_env
+ let nc = hsc_NC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
@@ -579,7 +592,8 @@ mergeSignatures
im = fst (getModuleInstantiation m)
fmap fst
. withException dflags
- $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot
+ $ findAndReadIface logger nc fc hooks unit_state home_unit dflags
+ (text "mergeSignatures") im m NotBoot
-- STEP 3: Get the unrenamed exports of all these interfaces,
-- thin it according to the export list, and do shaping on them.
@@ -990,7 +1004,16 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
let sig_mod = mkModule (VirtUnit uid) mod_name
isig_mod = fst (getModuleInstantiation sig_mod)
hsc_env <- getTopEnv
- mb_isig_iface <- liftIO $ findAndReadIface hsc_env (text "checkImplements 2") isig_mod sig_mod NotBoot
+ let nc = hsc_NC hsc_env
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
+ let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
+ mb_isig_iface <- liftIO $ findAndReadIface logger nc fc hooks units home_unit dflags
+ (text "checkImplements 2")
+ isig_mod sig_mod NotBoot
isig_iface <- case mb_isig_iface of
Succeeded (iface, _) -> return iface
Failed err -> failWithTc $
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index 130994b74b..cc2ccbe874 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -11,6 +11,7 @@ module GHC.Unit.Finder (
FindResult(..),
InstalledFindResult(..),
FinderCache,
+ initFinderCache,
flushFinderCaches,
findImportedModule,
findPluginModule,
@@ -35,7 +36,6 @@ module GHC.Unit.Finder (
import GHC.Prelude
-import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Platform.Ways
@@ -58,7 +58,7 @@ import GHC.Utils.Panic
import GHC.Linker.Types
-import Data.IORef ( IORef, readIORef, atomicModifyIORef' )
+import Data.IORef
import System.Directory
import System.FilePath
import Control.Monad
@@ -81,26 +81,28 @@ type BaseName = String -- Basename of file
-- -----------------------------------------------------------------------------
-- The finder's cache
+
+initFinderCache :: IO FinderCache
+initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv
+
-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session.
-flushFinderCaches :: HscEnv -> IO ()
-flushFinderCaches hsc_env =
- atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+flushFinderCaches :: FinderCache -> HomeUnit -> IO ()
+flushFinderCaches (FinderCache ref) home_unit =
+ atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
where
- fc_ref = hsc_FC hsc_env
- home_unit = hsc_home_unit hsc_env
- is_ext mod _ = not (isHomeInstalledModule home_unit mod)
+ is_ext mod _ = not (isHomeInstalledModule home_unit mod)
-addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
-addToFinderCache ref key val =
+addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
+addToFinderCache (FinderCache ref) key val =
atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
-removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
-removeFromFinderCache ref key =
+removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()
+removeFromFinderCache (FinderCache ref) key =
atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
-lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
-lookupFinderCache ref key = do
+lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
+lookupFinderCache (FinderCache ref) key = do
c <- readIORef ref
return $! lookupInstalledModuleEnv c key
@@ -113,30 +115,37 @@ lookupFinderCache ref key = do
-- packages to find the module, if a package is specified then only
-- that package is searched for the module.
-findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
-findImportedModule hsc_env mod_name mb_pkg =
+findImportedModule
+ :: FinderCache
+ -> UnitState
+ -> HomeUnit
+ -> DynFlags
+ -> ModuleName
+ -> Maybe FastString
+ -> IO FindResult
+findImportedModule fc units home_unit dflags mod_name mb_pkg =
case mb_pkg of
Nothing -> unqual_import
Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
| otherwise -> pkg_import
where
- home_import = findHomeModule hsc_env mod_name
+ home_import = findHomeModule fc home_unit dflags mod_name
- pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc units dflags mod_name mb_pkg
unqual_import = home_import
`orIfNotFound`
- findExposedPackageModule hsc_env mod_name Nothing
+ findExposedPackageModule fc units dflags mod_name Nothing
-- | Locate a plugin module requested by the user, for a compiler
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModule :: HscEnv -> ModuleName -> IO FindResult
-findPluginModule hsc_env mod_name =
- findHomeModule hsc_env mod_name
+findPluginModule :: FinderCache -> UnitState -> HomeUnit -> DynFlags -> ModuleName -> IO FindResult
+findPluginModule fc units home_unit dflags mod_name =
+ findHomeModule fc home_unit dflags mod_name
`orIfNotFound`
- findExposedPluginPackageModule hsc_env mod_name
+ findExposedPluginPackageModule fc units dflags mod_name
-- | Locate a specific 'Module'. The purpose of this function is to
-- create a 'ModLocation' for a given 'Module', that is to find out
@@ -144,12 +153,11 @@ findPluginModule hsc_env mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
-findExactModule hsc_env mod =
- let home_unit = hsc_home_unit hsc_env
- in if isHomeInstalledModule home_unit mod
- then findInstalledHomeModule hsc_env (moduleName mod)
- else findPackageModule hsc_env mod
+findExactModule :: FinderCache -> DynFlags -> UnitState -> HomeUnit -> InstalledModule -> IO InstalledFindResult
+findExactModule fc dflags unit_state home_unit mod = do
+ if isHomeInstalledModule home_unit mod
+ then findInstalledHomeModule fc dflags home_unit (moduleName mod)
+ else findPackageModule fc unit_state dflags mod
-- -----------------------------------------------------------------------------
-- Helpers
@@ -184,31 +192,26 @@ orIfNotFound this or_this = do
-- been done. Otherwise, do the lookup (with the IO action) and save
-- the result in the finder cache and the module location cache (if it
-- was successful.)
-homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
-homeSearchCache hsc_env mod_name do_this = do
- let home_unit = hsc_home_unit hsc_env
- mod = mkHomeInstalledModule home_unit mod_name
- modLocationCache hsc_env mod do_this
-
-findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
- -> IO FindResult
-findExposedPackageModule hsc_env mod_name mb_pkg
- = findLookupResult hsc_env
- $ lookupModuleWithSuggestions
- (hsc_units hsc_env) mod_name mb_pkg
-
-findExposedPluginPackageModule :: HscEnv -> ModuleName
- -> IO FindResult
-findExposedPluginPackageModule hsc_env mod_name
- = findLookupResult hsc_env
- $ lookupPluginModuleWithSuggestions
- (hsc_units hsc_env) mod_name Nothing
-
-findLookupResult :: HscEnv -> LookupResult -> IO FindResult
-findLookupResult hsc_env r = case r of
+homeSearchCache :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
+homeSearchCache fc home_unit mod_name do_this = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ modLocationCache fc mod do_this
+
+findExposedPackageModule :: FinderCache -> UnitState -> DynFlags -> ModuleName -> Maybe FastString -> IO FindResult
+findExposedPackageModule fc units dflags mod_name mb_pkg =
+ findLookupResult fc dflags
+ $ lookupModuleWithSuggestions units mod_name mb_pkg
+
+findExposedPluginPackageModule :: FinderCache -> UnitState -> DynFlags -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc units dflags mod_name =
+ findLookupResult fc dflags
+ $ lookupPluginModuleWithSuggestions units mod_name Nothing
+
+findLookupResult :: FinderCache -> DynFlags -> LookupResult -> IO FindResult
+findLookupResult fc dflags r = case r of
LookupFound m pkg_conf -> do
let im = fst (getModuleInstantiation m)
- r' <- findPackageModule_ hsc_env im pkg_conf
+ r' <- findPackageModule_ fc dflags im pkg_conf
case r' of
-- TODO: ghc -M is unlikely to do the right thing
-- with just the location of the thing that was
@@ -241,7 +244,7 @@ findLookupResult hsc_env r = case r of
, fr_suggestions = [] })
LookupNotFound suggest -> do
let suggest'
- | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest
+ | gopt Opt_HelpfulErrors dflags = suggest
| otherwise = []
return (NotFound{ fr_paths = [], fr_pkg = Nothing
, fr_pkgs_hidden = []
@@ -249,36 +252,35 @@ findLookupResult hsc_env r = case r of
, fr_unusables = []
, fr_suggestions = suggest' })
-modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
-modLocationCache hsc_env mod do_this = do
- m <- lookupFinderCache (hsc_FC hsc_env) mod
+modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache fc mod do_this = do
+ m <- lookupFinderCache fc mod
case m of
Just result -> return result
Nothing -> do
result <- do_this
- addToFinderCache (hsc_FC hsc_env) mod result
+ addToFinderCache fc mod result
return result
-- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
-addHomeModuleToFinder hsc_env mod_name loc = do
- let home_unit = hsc_home_unit hsc_env
- mod = mkHomeInstalledModule home_unit mod_name
- addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
+addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
+addHomeModuleToFinder fc home_unit mod_name loc = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ addToFinderCache fc mod (InstalledFound loc mod)
return (mkHomeModule home_unit mod_name)
-uncacheModule :: HscEnv -> ModuleName -> IO ()
-uncacheModule hsc_env mod_name = do
- let home_unit = hsc_home_unit hsc_env
- mod = mkHomeInstalledModule home_unit mod_name
- removeFromFinderCache (hsc_FC hsc_env) mod
+uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()
+uncacheModule fc home_unit mod_name = do
+ let mod = mkHomeInstalledModule home_unit mod_name
+ removeFromFinderCache fc mod
-- -----------------------------------------------------------------------------
-- The internal workers
-findHomeModule :: HscEnv -> ModuleName -> IO FindResult
-findHomeModule hsc_env mod_name = do
- r <- findInstalledHomeModule hsc_env mod_name
+findHomeModule :: FinderCache -> HomeUnit -> DynFlags -> ModuleName -> IO FindResult
+findHomeModule fc home_unit dflags mod_name = do
+ let uid = homeUnitAsUnit home_unit
+ r <- findInstalledHomeModule fc dflags home_unit mod_name
return $ case r of
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
@@ -290,9 +292,6 @@ findHomeModule hsc_env mod_name = do
fr_unusables = [],
fr_suggestions = []
}
- where
- home_unit = hsc_home_unit hsc_env
- uid = homeUnitAsUnit home_unit
-- | Implements the search for a module name in the home package only. Calling
-- this function directly is usually *not* what you want; currently, it's used
@@ -310,12 +309,10 @@ findHomeModule hsc_env mod_name = do
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
-- call this.)
-findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult
-findInstalledHomeModule hsc_env mod_name =
- homeSearchCache hsc_env mod_name $
+findInstalledHomeModule :: FinderCache -> DynFlags -> HomeUnit -> ModuleName -> IO InstalledFindResult
+findInstalledHomeModule fc dflags home_unit mod_name = do
+ homeSearchCache fc home_unit mod_name $
let
- dflags = hsc_dflags hsc_env
- home_unit = hsc_home_unit hsc_env
home_path = importPaths dflags
hisuf = hiSuf dflags
mod = mkHomeInstalledModule home_unit mod_name
@@ -340,21 +337,21 @@ findInstalledHomeModule hsc_env mod_name =
| otherwise = source_exts
in
- -- special case for GHC.Prim; we won't find it in the filesystem.
- -- This is important only when compiling the base package (where GHC.Prim
- -- is a home module).
- if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
- else searchPathExts home_path mod exts
+ -- special case for GHC.Prim; we won't find it in the filesystem.
+ -- This is important only when compiling the base package (where GHC.Prim
+ -- is a home module).
+ if mod `installedModuleEq` gHC_PRIM
+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ else searchPathExts home_path mod exts
-- | Search for a module in external packages only.
-findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
-findPackageModule hsc_env mod = do
+findPackageModule :: FinderCache -> UnitState -> DynFlags -> InstalledModule -> IO InstalledFindResult
+findPackageModule fc unit_state dflags mod = do
let pkg_id = moduleUnit mod
- case lookupUnitId (hsc_units hsc_env) pkg_id of
+ case lookupUnitId unit_state pkg_id of
Nothing -> return (InstalledNoPackage pkg_id)
- Just u -> findPackageModule_ hsc_env mod u
+ Just u -> findPackageModule_ fc dflags mod u
-- | Look up the interface file associated with module @mod@. This function
-- requires a few invariants to be upheld: (1) the 'Module' in question must
@@ -363,39 +360,38 @@ findPackageModule hsc_env mod = do
-- the 'UnitInfo' must be consistent with the unit id in the 'Module'.
-- The redundancy is to avoid an extra lookup in the package state
-- for the appropriate config.
-findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult
-findPackageModule_ hsc_env mod pkg_conf =
- ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )
- modLocationCache hsc_env mod $
-
- -- special case for GHC.Prim; we won't find it in the filesystem.
- if mod `installedModuleEq` gHC_PRIM
- then return (InstalledFound (error "GHC.Prim ModLocation") mod)
- else
-
- let
- dflags = hsc_dflags hsc_env
- tag = waysBuildTag (ways dflags)
-
- -- hi-suffix for packages depends on the build tag.
- package_hisuf | null tag = "hi"
- | otherwise = tag ++ "_hi"
-
- mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf
-
- import_dirs = map ST.unpack $ unitImportDirs pkg_conf
- -- we never look for a .hi-boot file in an external package;
- -- .hi-boot files only make sense for the home package.
- in
- case import_dirs of
- [one] | MkDepend <- ghcMode dflags -> do
- -- there's only one place that this .hi file can be, so
- -- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
- loc <- mk_hi_loc one basename
- return (InstalledFound loc mod)
- _otherwise ->
- searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
+findPackageModule_ :: FinderCache -> DynFlags -> InstalledModule -> UnitInfo -> IO InstalledFindResult
+findPackageModule_ fc dflags mod pkg_conf = do
+ MASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )
+ modLocationCache fc mod $
+
+ -- special case for GHC.Prim; we won't find it in the filesystem.
+ if mod `installedModuleEq` gHC_PRIM
+ then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+ else
+
+ let
+ tag = waysBuildTag (ways dflags)
+
+ -- hi-suffix for packages depends on the build tag.
+ package_hisuf | null tag = "hi"
+ | otherwise = tag ++ "_hi"
+
+ mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf
+
+ import_dirs = map ST.unpack $ unitImportDirs pkg_conf
+ -- we never look for a .hi-boot file in an external package;
+ -- .hi-boot files only make sense for the home package.
+ in
+ case import_dirs of
+ [one] | MkDepend <- ghcMode dflags -> do
+ -- there's only one place that this .hi file can be, so
+ -- don't bother looking for it.
+ let basename = moduleNameSlashes (moduleName mod)
+ loc <- mk_hi_loc one basename
+ return (InstalledFound loc mod)
+ _otherwise ->
+ searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
-- -----------------------------------------------------------------------------
-- General path searching
diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs
index 094f77be3a..06f4ea8aae 100644
--- a/compiler/GHC/Unit/Finder/Types.hs
+++ b/compiler/GHC/Unit/Finder/Types.hs
@@ -1,5 +1,6 @@
module GHC.Unit.Finder.Types
- ( FinderCache
+ ( FinderCache (..)
+ , FinderCacheState
, FindResult (..)
, InstalledFindResult (..)
)
@@ -9,12 +10,15 @@ import GHC.Prelude
import GHC.Unit
import GHC.Unit.State
+import Data.IORef
+
-- | The 'FinderCache' maps modules to the result of
-- searching for that module. It records the results of searching for
-- modules along the search path. On @:load@, we flush the entire
-- contents of this cache.
--
-type FinderCache = InstalledModuleEnv InstalledFindResult
+type FinderCacheState = InstalledModuleEnv InstalledFindResult
+newtype FinderCache = FinderCache (IORef FinderCacheState)
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 494ab29021..f698b5abed 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1998,8 +1998,12 @@ addModule files = do
checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool
checkTargetModule m = do
hsc_env <- GHC.getSession
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
result <- liftIO $
- Finder.findImportedModule hsc_env m (Just (fsLit "this"))
+ Finder.findImportedModule fc units home_unit dflags m (Just (fsLit "this"))
case result of
Found _ _ -> return True
_ -> (liftIO $ putStrLn $
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 1ea72d0b1c..00aeaf5028 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -244,7 +244,8 @@ main' postLoadMode dflags0 args flagWarnings = do
GHC.printException e
liftIO $ exitWith (ExitFailure 1)) $ do
case postLoadMode of
- ShowInterface f -> liftIO $ showIface (hsc_dflags hsc_env)
+ ShowInterface f -> liftIO $ showIface (hsc_logger hsc_env)
+ (hsc_dflags hsc_env)
(hsc_units hsc_env)
(hsc_NC hsc_env)
f
@@ -836,13 +837,16 @@ abiHash :: [String] -- ^ List of module names
-> Ghc ()
abiHash strs = do
hsc_env <- getSession
- let dflags = hsc_dflags hsc_env
+ let fc = hsc_FC hsc_env
+ let home_unit = hsc_home_unit hsc_env
+ let units = hsc_units hsc_env
+ let dflags = hsc_dflags hsc_env
liftIO $ do
let find_it str = do
let modname = mkModuleName str
- r <- findImportedModule hsc_env modname Nothing
+ r <- findImportedModule fc units home_unit dflags modname Nothing
case r of
Found _ m -> return m
_error -> throwGhcException $ CmdLineError $ showSDoc dflags $
diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs
index 153509f29e..122fdfd1c4 100644
--- a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs
+++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs
@@ -5,6 +5,7 @@
import GHC
import GHC.Driver.Make
import GHC.Driver.Session
+import GHC.Driver.Env
import GHC.Unit.Module.ModSummary (ExtendedModSummary(..))
import GHC.Unit.Finder
@@ -47,7 +48,7 @@ main = do
_emss <- downsweep hsc_env [] [] False
- flushFinderCaches hsc_env
+ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env)
createDirectoryIfMissing False "mydir"
renameFile "B.hs" "mydir/B.hs"