summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2021-07-20 11:49:22 +0200
committerMatthew Pickering <matthewtpickering@gmail.com>2021-12-28 09:47:53 +0000
commitfd42ab5fa1df847a6b595dfe4b63d9c7eecbf400 (patch)
tree3bd7add640ee4e1340de079a16a05fd34548925f /compiler/GHC
parent3219610e3ba6cb6a5cd1f4e32e2b4befea5bd384 (diff)
downloadhaskell-fd42ab5fa1df847a6b595dfe4b63d9c7eecbf400.tar.gz
Multiple Home Units
Multiple home units allows you to load different packages which may depend on each other into one GHC session. This will allow both GHCi and HLS to support multi component projects more naturally. Public Interface ~~~~~~~~~~~~~~~~ In order to specify multiple units, the -unit @⟨filename⟩ flag is given multiple times with a response file containing the arguments for each unit. The response file contains a newline separated list of arguments. ``` ghc -unit @unitLibCore -unit @unitLib ``` where the `unitLibCore` response file contains the normal arguments that cabal would pass to `--make` mode. ``` -this-unit-id lib-core-0.1.0.0 -i -isrc LibCore.Utils LibCore.Types ``` The response file for lib, can specify a dependency on lib-core, so then modules in lib can use modules from lib-core. ``` -this-unit-id lib-0.1.0.0 -package-id lib-core-0.1.0.0 -i -isrc Lib.Parse Lib.Render ``` Then when the compiler starts in --make mode it will compile both units lib and lib-core. There is also very basic support for multiple home units in GHCi, at the moment you can start a GHCi session with multiple units but only the :reload is supported. Most commands in GHCi assume a single home unit, and so it is additional work to work out how to modify the interface to support multiple loaded home units. Options used when working with Multiple Home Units There are a few extra flags which have been introduced specifically for working with multiple home units. The flags allow a home unit to pretend it’s more like an installed package, for example, specifying the package name, module visibility and reexported modules. -working-dir ⟨dir⟩ It is common to assume that a package is compiled in the directory where its cabal file resides. Thus, all paths used in the compiler are assumed to be relative to this directory. When there are multiple home units the compiler is often not operating in the standard directory and instead where the cabal.project file is located. In this case the -working-dir option can be passed which specifies the path from the current directory to the directory the unit assumes to be it’s root, normally the directory which contains the cabal file. When the flag is passed, any relative paths used by the compiler are offset by the working directory. Notably this includes -i and -I⟨dir⟩ flags. -this-package-name ⟨name⟩ This flag papers over the awkward interaction of the PackageImports and multiple home units. When using PackageImports you can specify the name of the package in an import to disambiguate between modules which appear in multiple packages with the same name. This flag allows a home unit to be given a package name so that you can also disambiguate between multiple home units which provide modules with the same name. -hidden-module ⟨module name⟩ This flag can be supplied multiple times in order to specify which modules in a home unit should not be visible outside of the unit it belongs to. The main use of this flag is to be able to recreate the difference between an exposed and hidden module for installed packages. -reexported-module ⟨module name⟩ This flag can be supplied multiple times in order to specify which modules are not defined in a unit but should be reexported. The effect is that other units will see this module as if it was defined in this unit. The use of this flag is to be able to replicate the reexported modules feature of packages with multiple home units. Offsetting Paths in Template Haskell splices ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When using Template Haskell to embed files into your program, traditionally the paths have been interpreted relative to the directory where the .cabal file resides. This causes problems for multiple home units as we are compiling many different libraries at once which have .cabal files in different directories. For this purpose we have introduced a way to query the value of the -working-dir flag to the Template Haskell API. By using this function we can implement a makeRelativeToProject function which offsets a path which is relative to the original project root by the value of -working-dir. ``` import Language.Haskell.TH.Syntax ( makeRelativeToProject ) foo = $(makeRelativeToProject "./relative/path" >>= embedFile) ``` > If you write a relative path in a Template Haskell splice you should use the makeRelativeToProject function so that your library works correctly with multiple home units. A similar function already exists in the file-embed library. The function in template-haskell implements this function in a more robust manner by honouring the -working-dir flag rather than searching the file system. Closure Property for Home Units ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For tools or libraries using the API there is one very important closure property which must be adhered to: > Any dependency which is not a home unit must not (transitively) depend on a home unit. For example, if you have three packages p, q and r, then if p depends on q which depends on r then it is illegal to load both p and r as home units but not q, because q is a dependency of the home unit p which depends on another home unit r. If you are using GHC by the command line then this property is checked, but if you are using the API then you need to check this property yourself. If you get it wrong you will probably get some very confusing errors about overlapping instances. Limitations of Multiple Home Units ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a few limitations of the initial implementation which will be smoothed out on user demand. * Package thinning/renaming syntax is not supported * More complicated reexports/renaming are not yet supported. * It’s more common to run into existing linker bugs when loading a large number of packages in a session (for example #20674, #20689) * Backpack is not yet supported when using multiple home units. * Dependency chasing can be quite slow with a large number of modules and packages. * Loading wired-in packages as home units is currently not supported (this only really affects GHC developers attempting to load template-haskell). * Barely any normal GHCi features are supported, it would be good to support enough for ghcid to work correctly. Despite these limitations, the implementation works already for nearly all packages. It has been testing on large dependency closures, including the whole of head.hackage which is a total of 4784 modules from 452 packages. Internal Changes ~~~~~~~~~~~~~~~~ * The biggest change is that the HomePackageTable is replaced with the HomeUnitGraph. The HomeUnitGraph is a map from UnitId to HomeUnitEnv, which contains information specific to each home unit. * The HomeUnitEnv contains: - A unit state, each home unit can have different package db flags - A set of dynflags, each home unit can have different flags - A HomePackageTable * LinkNode: A new node type is added to the ModuleGraph, this is used to place the linking step into the build plan so linking can proceed in parralel with other packages being built. * New invariant: Dependencies of a ModuleGraphNode can be completely determined by looking at the value of the node. In order to achieve this, downsweep now performs a more complete job of downsweeping and then the dependenices are recorded forever in the node rather than being computed again from the ModSummary. * Some transitive module calculations are rewritten to use the ModuleGraph which is more efficient. * There is always an active home unit, which simplifies modifying a lot of the existing API code which is unit agnostic (for example, in the driver). The road may be bumpy for a little while after this change but the basics are well-tested. One small metric increase, which we accept and also submodule update to haddock which removes ExtendedModSummary. Closes #10827 ------------------------- Metric Increase: MultiLayerModules ------------------------- Co-authored-by: Fendor <power.walross@gmail.com>
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Core/Opt/Pipeline.hs4
-rw-r--r--compiler/GHC/Driver/Backpack.hs78
-rw-r--r--compiler/GHC/Driver/Config/Finder.hs5
-rw-r--r--compiler/GHC/Driver/Env.hs128
-rw-r--r--compiler/GHC/Driver/Env/Types.hs2
-rw-r--r--compiler/GHC/Driver/Errors/Ppr.hs38
-rw-r--r--compiler/GHC/Driver/Errors/Types.hs14
-rw-r--r--compiler/GHC/Driver/Main.hs64
-rw-r--r--compiler/GHC/Driver/Make.hs1086
-rw-r--r--compiler/GHC/Driver/MakeFile.hs38
-rw-r--r--compiler/GHC/Driver/Pipeline.hs35
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs28
-rw-r--r--compiler/GHC/Driver/Pipeline/LogQueue.hs26
-rw-r--r--compiler/GHC/Driver/Session.hs55
-rw-r--r--compiler/GHC/HsToCore/Usage.hs4
-rw-r--r--compiler/GHC/Iface/Errors.hs4
-rw-r--r--compiler/GHC/Iface/Load.hs78
-rw-r--r--compiler/GHC/Iface/Recomp.hs62
-rw-r--r--compiler/GHC/Iface/Recomp/Flags.hs2
-rw-r--r--compiler/GHC/IfaceToCore.hs15
-rw-r--r--compiler/GHC/Linker/Loader.hs165
-rw-r--r--compiler/GHC/Linker/Static.hs29
-rw-r--r--compiler/GHC/Linker/Static/Utils.hs31
-rw-r--r--compiler/GHC/Rename/Names.hs37
-rw-r--r--compiler/GHC/Runtime/Eval.hs8
-rw-r--r--compiler/GHC/Runtime/Loader.hs2
-rw-r--r--compiler/GHC/SysTools/Tasks.hs13
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs5
-rw-r--r--compiler/GHC/Tc/Instance/Family.hs10
-rw-r--r--compiler/GHC/Tc/Module.hs18
-rw-r--r--compiler/GHC/Tc/Plugin.hs11
-rw-r--r--compiler/GHC/Tc/Types.hs20
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs42
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs3
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs12
-rw-r--r--compiler/GHC/Types/Name/Ppr.hs2
-rw-r--r--compiler/GHC/Types/PkgQual.hs5
-rw-r--r--compiler/GHC/Types/Target.hs4
-rw-r--r--compiler/GHC/Unit.hs2
-rw-r--r--compiler/GHC/Unit/Env.hs538
-rw-r--r--compiler/GHC/Unit/External.hs5
-rw-r--r--compiler/GHC/Unit/Finder.hs131
-rw-r--r--compiler/GHC/Unit/Finder/Types.hs8
-rw-r--r--compiler/GHC/Unit/Home/ModInfo.hs3
-rw-r--r--compiler/GHC/Unit/Module.hs2
-rw-r--r--compiler/GHC/Unit/Module/Deps.hs24
-rw-r--r--compiler/GHC/Unit/Module/Env.hs34
-rw-r--r--compiler/GHC/Unit/Module/Graph.hs162
-rw-r--r--compiler/GHC/Unit/Module/ModSummary.hs44
-rw-r--r--compiler/GHC/Unit/State.hs48
-rw-r--r--compiler/GHC/Unit/Types.hs9
52 files changed, 2110 insertions, 1085 deletions
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 6b68ccee64..41bae56242 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -72,6 +72,7 @@ import GHC.Types.Name.Ppr
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Unit.Module
{-
************************************************************************
* *
@@ -106,7 +107,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
where
logger = hsc_logger hsc_env
dflags = hsc_dflags hsc_env
- home_pkg_rules = hptRules hsc_env (dep_direct_mods deps)
+ home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
+ , gwib_isBoot = NotBoot })
hpt_rule_base = mkRuleBase home_pkg_rules
print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 8ca120e462..b4e530a3e9 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -183,7 +183,8 @@ withBkpSession cid insts deps session_type do_this = do
, not (null insts) = sub_comp (key_base p) </> uid_str
| otherwise = sub_comp (key_base p)
- mk_temp_env hsc_env = hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
+ mk_temp_env hsc_env =
+ hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
mk_temp_dflags unit_state dflags = dflags
{ backend = case session_type of
TcSession -> NoBackend
@@ -322,7 +323,7 @@ buildUnit session cid insts lunit = do
conf <- withBkpSession cid insts deps_w_rns session $ do
dflags <- getDynFlags
- mod_graph <- hsunitModuleGraph (unLoc lunit)
+ mod_graph <- hsunitModuleGraph False (unLoc lunit)
msg <- mkBackpackMsg
(ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
@@ -412,7 +413,7 @@ compileExe lunit = do
forM_ (zip [1..] deps) $ \(i, dep) ->
compileInclude (length deps) (i, dep)
withBkpExeSession deps_w_rns $ do
- mod_graph <- hsunitModuleGraph (unLoc lunit)
+ mod_graph <- hsunitModuleGraph True (unLoc lunit)
msg <- mkBackpackMsg
(ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph
when (failed ok) (liftIO $ exitWith (ExitFailure 1))
@@ -432,19 +433,21 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
- let unit_env = UnitEnv
+ let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv
{ ue_platform = targetPlatform dflags
, ue_namever = ghcNameVersion dflags
- , ue_home_unit = Just home_unit
- , ue_hpt = ue_hpt old_unit_env
+ , ue_current_unit = homeUnitId home_unit
+
+ , ue_home_unit_graph =
+ unitEnv_singleton
+ (homeUnitId home_unit)
+ (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
- , ue_units = unit_state
- , ue_unit_dbs = Just dbs
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -565,7 +568,7 @@ mkBackpackMsg = do
msg <> showModMsg dflags (recompileRequired recomp) node
<> reason
in case node of
- InstantiationNode _ ->
+ InstantiationNode _ _ ->
case recomp of
MustCompile -> showMsg (text "Instantiating ") empty
UpToDate
@@ -573,7 +576,7 @@ mkBackpackMsg = do
| otherwise -> return ()
RecompBecause reason -> showMsg (text "Instantiating ")
(text " [" <> pprWithUnitState state (ppr reason) <> text "]")
- ModuleNode _ ->
+ ModuleNode _ _ ->
case recomp of
MustCompile -> showMsg (text "Compiling ") empty
UpToDate
@@ -581,6 +584,7 @@ mkBackpackMsg = do
| otherwise -> return ()
RecompBecause reason -> showMsg (text "Compiling ")
(text " [" <> pprWithUnitState state (ppr reason) <> text "]")
+ LinkNode _ _ -> showMsg (text "Linking ") empty
-- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not
@@ -709,38 +713,40 @@ convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsCo
--
-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
-- than it's worth for inline modules.
-hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph
-hsunitModuleGraph unit = do
+hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph do_link unit = do
hsc_env <- getSession
let decls = hsunitBody unit
pn = hsPackageName (unLoc (hsunitName unit))
home_unit = hsc_home_unit hsc_env
+ sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit))
+ keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ]
+
-- 1. Create a HsSrcFile/HsigFile summary for every
-- explicitly mentioned module/signature.
let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =
- Just `fmap` summariseDecl pn hsc_src lmodname hsmod
+ Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys)
get_decl _ = return Nothing
- nodes <- catMaybes `fmap` mapM get_decl decls
+ nodes <- mapMaybeM get_decl decls
-- 2. For each hole which does not already have an hsig file,
-- create an "empty" hsig file to induce compilation for the
-- requirement.
let hsig_set = Set.fromList
[ ms_mod_name ms
- | ExtendedModSummary { emsModSummary = ms } <- nodes
+ | ModuleNode _ ms <- nodes
, ms_hsc_src ms == HsigFile
]
req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
if Set.member mod_name hsig_set
then return Nothing
- else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name
- -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
- -- representing a signature that can't depend on any other unit.
+ else fmap Just $ summariseRequirement pn mod_name
- let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env))
+ let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))
key_nodes = map mkNodeKey graph_nodes
+ all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link]
-- This error message is not very good but .bkp mode is just for testing so
-- better to be direct rather than pretty.
when
@@ -748,10 +754,10 @@ hsunitModuleGraph unit = do
(pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))
-- 3. Return the kaboodle
- return $ mkModuleGraph' $ graph_nodes
+ return $ mkModuleGraph $ all_nodes
-summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
+summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode
summariseRequirement pn mod_name = do
hsc_env <- getSession
let dflags = hsc_dflags hsc_env
@@ -773,7 +779,7 @@ summariseRequirement pn mod_name = do
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
- return ModSummary {
+ let ms = ModSummary {
ms_mod = mod,
ms_hsc_src = HsigFile,
ms_location = location,
@@ -802,25 +808,29 @@ summariseRequirement pn mod_name = do
ms_hspp_opts = dflags,
ms_hspp_buf = Nothing
}
+ let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]
+ return (ModuleNode nodes ms)
summariseDecl :: PackageName
-> HscSource
-> Located ModuleName
-> Located HsModule
- -> BkpM ExtendedModSummary
-summariseDecl pn hsc_src (L _ modname) hsmod = hsModuleToModSummary pn hsc_src modname hsmod
+ -> [NodeKey]
+ -> BkpM ModuleGraphNode
+summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod
-- | Up until now, GHC has assumed a single compilation target per source file.
-- Backpack files with inline modules break this model, since a single file
-- may generate multiple output files. How do we decide to name these files?
-- Should there only be one output file? This function our current heuristic,
-- which is we make a "fake" module and use that.
-hsModuleToModSummary :: PackageName
+hsModuleToModSummary :: [NodeKey]
+ -> PackageName
-> HscSource
-> ModuleName
-> Located HsModule
- -> BkpM ExtendedModSummary
-hsModuleToModSummary pn hsc_src modname
+ -> BkpM ModuleGraphNode
+hsModuleToModSummary home_keys pn hsc_src modname
hsmod = do
let imps = hsmodImports (unLoc hsmod)
loc = getLoc hsmod
@@ -876,9 +886,7 @@ hsModuleToModSummary pn hsc_src modname
let home_unit = hsc_home_unit hsc_env
let fc = hsc_FC hsc_env
addHomeModuleToFinder fc home_unit modname location
- return $ ExtendedModSummary
- { emsModSummary =
- ModSummary {
+ let ms = ModSummary {
ms_mod = this_mod,
ms_hsc_src = hsc_src,
ms_location = location,
@@ -909,8 +917,12 @@ hsModuleToModSummary pn hsc_src modname
ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp
}
- , emsInstantiatedUnits = inst_deps
- }
+
+ -- Now, what are the dependencies.
+ let inst_nodes = map NodeKey_Unit inst_deps
+ mod_nodes = [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]
+
+ return (ModuleNode (mod_nodes ++ inst_nodes) ms)
-- | Create a new, externally provided hashed unit id from
-- a hash.
diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs
index 3d830fc6d2..6a7ad78972 100644
--- a/compiler/GHC/Driver/Config/Finder.hs
+++ b/compiler/GHC/Driver/Config/Finder.hs
@@ -7,6 +7,7 @@ import GHC.Prelude
import GHC.Driver.Session
import GHC.Unit.Finder.Types
+import GHC.Data.FastString
-- | Create a new 'FinderOpts' from DynFlags.
@@ -17,6 +18,10 @@ initFinderOpts flags = FinderOpts
, finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
, finder_ways = ways flags
, finder_enableSuggestions = gopt Opt_HelpfulErrors flags
+ , finder_workingDirectory = workingDirectory flags
+ , finder_thisPackageName = mkFastString <$> thisPackageName flags
+ , finder_hiddenModules = hiddenModules flags
+ , finder_reexportedModules = reexportedModules flags
, finder_hieDir = hieDir flags
, finder_hieSuf = hieSuf flags
, finder_hiDir = hiDir flags
diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs
index 02d9249bd1..777f97768e 100644
--- a/compiler/GHC/Driver/Env.hs
+++ b/compiler/GHC/Driver/Env.hs
@@ -9,8 +9,15 @@ module GHC.Driver.Env
, hsc_home_unit_maybe
, hsc_units
, hsc_HPT
- , hscUpdateHPT
+ , hsc_HUE
+ , hsc_HUG
+ , hsc_all_home_unit_ids
, hscUpdateLoggerFlags
+ , hscUpdateHUG
+ , hscUpdateHPT
+ , hscSetActiveHomeUnit
+ , hscSetActiveUnitId
+ , hscActiveUnitId
, runHsc
, runHsc'
, mkInteractiveHscEnv
@@ -47,7 +54,6 @@ import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo
import GHC.Unit.Env
import GHC.Unit.External
@@ -109,17 +115,29 @@ hsc_home_unit :: HscEnv -> HomeUnit
hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env
hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit
-hsc_home_unit_maybe = ue_home_unit . hsc_unit_env
+hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
-hsc_units :: HscEnv -> UnitState
+hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_units . hsc_unit_env
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
+hsc_HUE :: HscEnv -> HomeUnitEnv
+hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env
+
+hsc_HUG :: HscEnv -> HomeUnitGraph
+hsc_HUG = ue_home_unit_graph . hsc_unit_env
+
+hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId
+hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG
+
hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) }
+hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
+hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) }
+
{-
Note [Target code interpreter]
@@ -209,42 +227,47 @@ hptAllInstances hsc_env
in (concat insts, concat famInsts)
-- | Find instances visible from the given set of imports
-hptInstancesBelow :: HscEnv -> ModuleName -> Set ModuleNameWithIsBoot -> ([ClsInst], [FamInst])
-hptInstancesBelow hsc_env mn mns =
- hptSomeThingsBelowUs (\mod_info ->
- let details = hm_details mod_info
- -- Don't include instances for the current module
- in if moduleName (mi_module (hm_iface mod_info)) == mn
- then mempty
- else (md_insts details, md_fam_insts details))
- True -- Include -hi-boot
- hsc_env
- mns
+hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> ([ClsInst], [FamInst])
+hptInstancesBelow hsc_env uid mnwib =
+ let
+ mn = gwib_mod mnwib
+ (insts, famInsts) =
+ unzip $ hptSomeThingsBelowUs (\mod_info ->
+ let details = hm_details mod_info
+ -- Don't include instances for the current module
+ in if moduleName (mi_module (hm_iface mod_info)) == mn
+ then []
+ else [(md_insts details, md_fam_insts details)])
+ True -- Include -hi-boot
+ hsc_env
+ uid
+ mnwib
+ in (concat insts, concat famInsts)
-- | Get rules from modules "below" this one (in the dependency sense)
-hptRules :: HscEnv -> Set ModuleNameWithIsBoot -> [CoreRule]
+hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
-- | Get annotations from modules "below" this one (in the dependency sense)
-hptAnns :: HscEnv -> Maybe (Set ModuleNameWithIsBoot) -> [Annotation]
-hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
+hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]
+hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
-hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))
+hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)
+ (hugElts (hsc_HUG hsc_env))
-- | This function returns all the modules belonging to the home-unit that can
-- be reached by following the given dependencies. Additionally, if both the
-- boot module and the non-boot module can be reached, it only returns the
-- non-boot one.
-hptModulesBelow :: HscEnv -> Set ModuleNameWithIsBoot -> Set ModuleNameWithIsBoot
-hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <- modules_below]
+hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
+hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below]
where
td_map = mgTransDeps (hsc_mod_graph hsc_env)
- modules_below = Set.toList (Set.unions (mapMaybe (\mn -> Map.lookup (NodeKey_Module mn) td_map) (Set.toList mn))
- `Set.union` (Set.map NodeKey_Module mn))
+ modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map
filtered_mods = Set.fromDistinctAscList . filter_mods . sort
@@ -253,8 +276,9 @@ hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <-
-- linear sweep with a window of size 2 to remove boot modules for which we
-- have the corresponding non-boot.
filter_mods = \case
- (r1@(GWIB m1 b1) : r2@(GWIB m2 _) : rs)
- | m1 == m2 -> let !r' = case b1 of
+ (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs)
+ | m1 == m2 && uid1 == uid2 ->
+ let !r' = case b1 of
NotBoot -> r1
IsBoot -> r2
in r' : filter_mods rs
@@ -265,16 +289,17 @@ hptModulesBelow hsc_env mn = filtered_mods $ [ mnwib | NodeKey_Module mnwib <-
-- | Get things from modules "below" this one (in the dependency sense)
-- C.f Inst.hptInstances
-hptSomeThingsBelowUs :: Monoid a => (HomeModInfo -> a) -> Bool -> HscEnv -> Set ModuleNameWithIsBoot -> a
-hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
- | isOneShot (ghcMode (hsc_dflags hsc_env)) = mempty
+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]
+hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn
+ | isOneShot (ghcMode (hsc_dflags hsc_env)) = []
| otherwise
- = let hpt = hsc_HPT hsc_env
- in mconcat
+ = let hug = hsc_HUG hsc_env
+ in
[ thing
- | -- Find each non-hi-boot module below me
- GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- Set.toList (hptModulesBelow hsc_env deps)
+ |
+ -- Find each non-hi-boot module below me
+ (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) uid) <- Set.toList (hptModulesBelow hsc_env uid mn)
, include_hi_boot || (is_boot == NotBoot)
-- unsavoury: when compiling the base package with --make, we
@@ -284,12 +309,13 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
, mod /= moduleName gHC_PRIM
-- Look it up in the HPT
- , let thing = case lookupHpt hpt mod of
+ , let things = case lookupHug hug uid mod of
Just info -> extract info
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty
msg = vcat [text "missing module" <+> ppr mod,
text "Probable cause: out-of-date interface files"]
-- This really shouldn't happen, but see #962
+ , thing <- things
]
@@ -304,7 +330,8 @@ prepareAnnotations hsc_env mb_guts = do
-- Extract dependencies of the module if we are supplied one,
-- otherwise load annotations from all home package table
-- entries regardless of dependency ordering.
- home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_direct_mods . mg_deps) mb_guts
+ get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot)
+ home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts
other_pkg_anns = eps_ann_env eps
ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,
Just home_pkg_anns,
@@ -320,7 +347,7 @@ lookupType :: HscEnv -> Name -> IO (Maybe TyThing)
lookupType hsc_env name = do
eps <- liftIO $ hscEPS hsc_env
let pte = eps_PTE eps
- hpt = hsc_HPT hsc_env
+ hpt = hsc_HUG hsc_env
mod = assertPpr (isExternalName name) (ppr name) $
if isHoleName name
@@ -330,7 +357,7 @@ lookupType hsc_env name = do
!ty = if isOneShot (ghcMode (hsc_dflags hsc_env))
-- in one-shot, we don't use the HPT
then lookupNameEnv pte name
- else case lookupHptByModule hpt mod of
+ else case lookupHugByModule mod hpt of
Just hm -> lookupNameEnv (md_types (hm_details hm)) name
Nothing -> lookupNameEnv pte name
pure ty
@@ -338,12 +365,12 @@ lookupType hsc_env name = do
-- | Find the 'ModIface' for a 'Module', searching in both the loaded home
-- and external package module information
lookupIfaceByModule
- :: HomePackageTable
+ :: HomeUnitGraph
-> PackageIfaceTable
-> Module
-> Maybe ModIface
-lookupIfaceByModule hpt pit mod
- = case lookupHptByModule hpt mod of
+lookupIfaceByModule hug pit mod
+ = case lookupHugByModule mod hug of
Just hm -> Just (hm_iface hm)
Nothing -> lookupModuleEnv pit mod
-- If the module does come from the home package, why do we look in the PIT as well?
@@ -353,8 +380,8 @@ lookupIfaceByModule hpt pit mod
-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package
-- of its own, but it doesn't seem worth the bother.
-mainModIs :: HscEnv -> Module
-mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))
+mainModIs :: HomeUnitEnv -> Module
+mainModIs hue = mkHomeModule (expectJust "mainModIs" $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))
-- | Retrieve the target code interpreter
--
@@ -375,8 +402,19 @@ hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h
-- | Set Flags
-hscSetFlags :: DynFlags -> HscEnv -> HscEnv
+hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv
hscSetFlags dflags h =
- -- update LogFlags from the new DynFlags
- hscUpdateLoggerFlags
- $ h { hsc_dflags = dflags }
+ hscUpdateLoggerFlags $ h { hsc_dflags = dflags
+ , hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) }
+
+-- See Note [Multiple Home Units]
+hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv
+hscSetActiveHomeUnit home_unit = hscSetActiveUnitId (homeUnitId home_unit)
+
+hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv
+hscSetActiveUnitId uid e = e
+ { hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e)
+ , hsc_dflags = ue_unitFlags uid (hsc_unit_env e) }
+
+hscActiveUnitId :: HscEnv -> UnitId
+hscActiveUnitId e = ue_currentUnit (hsc_unit_env e)
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index b0fcc6fd64..9db617780b 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -7,7 +7,7 @@ module GHC.Driver.Env.Types
import GHC.Driver.Errors.Types ( GhcMessage )
import {-# SOURCE #-} GHC.Driver.Hooks
-import GHC.Driver.Session ( DynFlags, ContainsDynFlags(..), HasDynFlags(..) )
+import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags )
import GHC.Prelude
import GHC.Runtime.Context
import GHC.Runtime.Interpreter.Types ( Interp )
diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs
index 2d90e935c8..1b604e1071 100644
--- a/compiler/GHC/Driver/Errors/Ppr.hs
+++ b/compiler/GHC/Driver/Errors/Ppr.hs
@@ -88,6 +88,18 @@ instance Diagnostic DriverMessage where
4
(sep (map ppr missing))
in mkSimpleDecorated msg
+ DriverUnknownHiddenModules missing
+ -> let msg = hang
+ (text "Modules are listened as hidden but not part of the unit: ")
+ 4
+ (sep (map ppr missing))
+ in mkSimpleDecorated msg
+ DriverUnknownReexportedModules missing
+ -> let msg = hang
+ (text "Modules are listened as reexported but can't be found in any dependency: ")
+ 4
+ (sep (map ppr missing))
+ in mkSimpleDecorated msg
DriverUnusedPackages unusedArgs
-> let msg = vcat [ text "The following packages were specified" <+>
text "via -package or -package-id flags,"
@@ -171,6 +183,16 @@ instance Diagnostic DriverMessage where
<> (pprWithUnitState state $ ppr (moduleUnit m))
<> text ") the module resides in isn't trusted."
]
+ DriverRedirectedNoMain mod_name
+ -> mkSimpleDecorated $ (text
+ ("Output was redirected with -o, " ++
+ "but no output will be generated.") $$
+ (text "There is no module named" <+>
+ quotes (ppr mod_name) <> text "."))
+ DriverHomePackagesNotClosed needed_unit_ids
+ -> mkSimpleDecorated $ vcat ([text "Home units are not closed."
+ , text "It is necessary to also load the following units:" ]
+ ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
diagnosticReason = \case
DriverUnknownMessage m
@@ -179,6 +201,10 @@ instance Diagnostic DriverMessage where
-> ErrorWithoutFlag
DriverMissingHomeModules{}
-> WarningWithFlag Opt_WarnMissingHomeModules
+ DriverUnknownHiddenModules {}
+ -> ErrorWithoutFlag
+ DriverUnknownReexportedModules {}
+ -> ErrorWithoutFlag
DriverUnusedPackages{}
-> WarningWithFlag Opt_WarnUnusedPackages
DriverUnnecessarySourceImports{}
@@ -217,6 +243,10 @@ instance Diagnostic DriverMessage where
-> ErrorWithoutFlag
DriverCannotImportFromUntrustedPackage{}
-> ErrorWithoutFlag
+ DriverRedirectedNoMain {}
+ -> ErrorWithoutFlag
+ DriverHomePackagesNotClosed {}
+ -> ErrorWithoutFlag
diagnosticHints = \case
DriverUnknownMessage m
@@ -225,6 +255,10 @@ instance Diagnostic DriverMessage where
-> diagnosticHints psMsg
DriverMissingHomeModules{}
-> noHints
+ DriverUnknownHiddenModules {}
+ -> noHints
+ DriverUnknownReexportedModules {}
+ -> noHints
DriverUnusedPackages{}
-> noHints
DriverUnnecessarySourceImports{}
@@ -265,3 +299,7 @@ instance Diagnostic DriverMessage where
-> noHints
DriverCannotImportFromUntrustedPackage{}
-> noHints
+ DriverRedirectedNoMain {}
+ -> noHints
+ DriverHomePackagesNotClosed {}
+ -> noHints
diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs
index 178455187f..7257b23903 100644
--- a/compiler/GHC/Driver/Errors/Types.hs
+++ b/compiler/GHC/Driver/Errors/Types.hs
@@ -128,6 +128,16 @@ data DriverMessage where
-}
DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage
+ {-| DriverUnknown is a warning that arises when a user tries to
+ reexport a module which isn't part of that unit.
+ -}
+ DriverUnknownReexportedModules :: [ModuleName] -> DriverMessage
+
+ {-| DriverUnknownHiddenModules is a warning that arises when a user tries to
+ hide a module which isn't part of that unit.
+ -}
+ DriverUnknownHiddenModules :: [ModuleName] -> DriverMessage
+
{-| DriverUnusedPackages occurs when when package is requested on command line,
but was never needed during compilation. Activated by -Wunused-packages.
@@ -337,6 +347,10 @@ data DriverMessage where
-}
DriverCannotImportFromUntrustedPackage :: !UnitState -> !Module -> DriverMessage
+ DriverRedirectedNoMain :: !ModuleName -> DriverMessage
+
+ DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
+
-- | Pass to a 'DriverMessage' the information whether or not the
-- '-fbuilding-cabal-package' flag is set.
data BuildingCabalPackage
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 39c1f7af4e..38406fe172 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -39,9 +39,10 @@ module GHC.Driver.Main
(
-- * Making an HscEnv
newHscEnv
+ , newHscEnvWithHUG
-- * Compiling complete source files
- , Messager, batchMsg
+ , Messager, batchMsg, batchMultiMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, hscMaybeWriteIface
@@ -249,14 +250,22 @@ import Data.List.NonEmpty (NonEmpty ((:|)))
%********************************************************************* -}
newHscEnv :: DynFlags -> IO HscEnv
-newHscEnv dflags = do
+newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph
+ where
+ home_unit_graph = unitEnv_singleton
+ (homeUnitId_ dflags)
+ (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)
+
+newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
+newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do
nc_var <- initNameCache 'r' knownKeyNames
fc_var <- initFinderCache
logger <- initLogger
tmpfs <- initTmpFs
- unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags)
- return HscEnv { hsc_dflags = dflags
- , hsc_logger = setLogFlags logger (initLogFlags dflags)
+ let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph
+ unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
+ return HscEnv { hsc_dflags = top_dynflags
+ , hsc_logger = setLogFlags logger (initLogFlags top_dynflags)
, hsc_targets = []
, hsc_mod_graph = emptyMG
, hsc_IC = emptyInteractiveContext dflags
@@ -728,8 +737,7 @@ hscRecompStatus
= do
let
msg what = case mHscMessage of
- -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode
- Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))
+ Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)
Nothing -> return ()
-- First check to see if the interface file agrees with the
@@ -1107,31 +1115,33 @@ oneShotMsg logger recomp =
_ -> return ()
batchMsg :: Messager
-batchMsg hsc_env mod_index recomp node = case node of
- InstantiationNode _ ->
- case recomp of
- MustCompile -> showMsg (text "Instantiating ") empty
- UpToDate
- | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty
- | otherwise -> return ()
- RecompBecause reason -> showMsg (text "Instantiating ")
- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
- ModuleNode _ ->
- case recomp of
- MustCompile -> showMsg (text "Compiling ") empty
- UpToDate
- | logVerbAtLeast logger 2 -> showMsg (text "Skipping ") empty
- | otherwise -> return ()
- RecompBecause reason -> showMsg (text "Compiling ")
- (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
+batchMsg = batchMsgWith (\_ _ _ _ -> empty)
+batchMultiMsg :: Messager
+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))
+
+batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
+batchMsgWith extra hsc_env_start mod_index recomp node =
+ case recomp of
+ MustCompile -> showMsg (text herald) empty
+ UpToDate
+ | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty
+ | otherwise -> return ()
+ RecompBecause reason -> showMsg (text herald)
+ (text " [" <> pprWithUnitState state (ppr reason) <> text "]")
where
+ herald = case node of
+ LinkNode {} -> "Linking"
+ InstantiationNode {} -> "Instantiating"
+ ModuleNode {} -> "Compiling"
+ hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
state = hsc_units hsc_env
showMsg msg reason =
compilationProgressMsg logger $
(showModuleIndex mod_index <>
- msg <> showModMsg dflags (recompileRequired recomp) node)
+ msg <+> showModMsg dflags (recompileRequired recomp) node)
+ <> extra hsc_env mod_index recomp node
<> reason
--------------------------------------------------------------
@@ -1420,8 +1430,8 @@ hscCheckSafe' m l = do
hsc_env <- getHscEnv
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
- homePkgT = hsc_HPT hsc_env
- iface = lookupIfaceByModule homePkgT pkgIfaceT m
+ hug = hsc_HUG hsc_env
+ iface = lookupIfaceByModule hug pkgIfaceT m
-- the 'lookupIfaceByModule' method will always fail when calling from GHCi
-- as the compiler hasn't filled in the various module tables
-- so we need to call 'getModuleInterface' to load from disk
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 3a37a06809..afeec69c8e 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -16,6 +16,8 @@
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiWayIf #-}
-- -----------------------------------------------------------------------------
--
@@ -26,7 +28,7 @@
--
-- -----------------------------------------------------------------------------
module GHC.Driver.Make (
- depanal, depanalE, depanalPartial,
+ depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
load, loadWithCache, load', LoadHowMuch(..),
instantiationNodes,
@@ -37,6 +39,7 @@ module GHC.Driver.Make (
ms_home_srcimps, ms_home_imps,
summariseModule,
+ SummariseResult(..),
summariseFile,
hscSourceToIsBoot,
findExtraSigImports,
@@ -46,7 +49,8 @@ module GHC.Driver.Make (
SummaryNode,
IsBootInterface(..), mkNodeKey,
- ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
+ ModNodeKey, ModNodeKeyWithUid(..),
+ ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith
) where
import GHC.Prelude
@@ -104,8 +108,6 @@ import GHC.Types.SourceFile
import GHC.Types.SourceError
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM
-import GHC.Types.Unique.DSet
-import GHC.Types.Unique.Set
import GHC.Types.Name
import GHC.Types.PkgQual
@@ -118,19 +120,17 @@ import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Graph
import GHC.Unit.Home.ModInfo
-import Data.Either ( rights, partitionEithers )
+import Data.Either ( rights, partitionEithers, lefts )
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified GHC.Data.FiniteMap as Map ( insertListWith )
-import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
+import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
import qualified GHC.Conc as CC
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import qualified Control.Monad.Catch as MC
import Data.IORef
-import Data.Foldable (toList)
import Data.Maybe
import Data.Time
import Data.Bifunctor (first)
@@ -190,9 +190,21 @@ depanalE excluded_mods allow_dup_roots = do
(errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
if isEmptyMessages errs
then do
- let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph
- unused_pkg_err = warnUnusedPackages hsc_env mod_graph
- logDiagnostics (GhcDriverMessage <$> (unused_home_mod_err `unionMessages` unused_pkg_err))
+ hsc_env <- getSession
+ let one_unit_messages get_mod_errs k hue = do
+ errs <- get_mod_errs
+ unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
+
+ let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+
+
+ return $ errs `unionMessages` unused_home_mod_err
+ `unionMessages` unused_pkg_err
+ `unionMessages` unknown_module_err
+
+ all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)
+ logDiagnostics (GhcDriverMessage <$> all_errs)
setSession hsc_env { hsc_mod_graph = mod_graph }
pure (emptyMessages, mod_graph)
else do
@@ -233,16 +245,13 @@ 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_FC hsc_env) (hsc_home_unit hsc_env)
+ liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
- mod_summariesE <- liftIO $ downsweep
- hsc_env (mgExtendedModSummaries old_graph)
+ (errs, graph_nodes) <- liftIO $ downsweep
+ hsc_env (mgModSummaries old_graph)
excluded_mods allow_dup_roots
let
- (errs, mod_summaries) = partitionEithers mod_summariesE
- mod_graph = mkModuleGraph' $
- (instantiationNodes (hsc_units hsc_env))
- ++ fmap ModuleNode mod_summaries
+ mod_graph = mkModuleGraph graph_nodes
return (unionManyMessages errs, mod_graph)
-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
@@ -253,8 +262,8 @@ depanalPartial excluded_mods allow_dup_roots = do
-- In the future, perhaps more of the work of instantiation could be moved here,
-- instead of shoved in with the module compilation nodes. That could simplify
-- backpack, and maybe hs-boot too.
-instantiationNodes :: UnitState -> [ModuleGraphNode]
-instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
+instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
+instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check
where
iuids_to_check :: [InstantiatedUnit]
iuids_to_check =
@@ -267,6 +276,35 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
, recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
]
+-- The linking plan for each module. If we need to do linking for a home unit
+-- then this function returns a graph node which depends on all the modules in the home unit.
+
+-- At the moment nothing can depend on these LinkNodes.
+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
+linkNodes summaries uid hue =
+ let dflags = homeUnitEnv_dflags hue
+ ofile = outputFile_ dflags
+
+ unit_nodes :: [NodeKey]
+ unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ no_hs_main = gopt Opt_NoHsMain dflags
+
+ main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
+
+ do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
+
+ in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->
+ Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
+ -- This should be an error, not a warning (#10895).
+ | do_linking -> Just (Right (LinkNode unit_nodes uid))
+ | otherwise -> Nothing
+
-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
@@ -281,14 +319,12 @@ instantiationNodes unit_state = InstantiationNode <$> iuids_to_check
-- about module "C" not being listed in a command line.
--
-- The warning in enabled by `-Wmissing-home-modules`. See #13129
-warnMissingHomeModules :: HscEnv -> ModuleGraph -> DriverMessages
-warnMissingHomeModules hsc_env mod_graph =
- if null missing
- then emptyMessages
- else warn
+warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages
+warnMissingHomeModules dflags targets mod_graph =
+ if null missing
+ then emptyMessages
+ else warn
where
- dflags = hsc_dflags hsc_env
- targets = map targetId (hsc_targets hsc_env)
diag_opts = initDiagOpts dflags
is_known_module mod = any (is_my_target mod) targets
@@ -301,36 +337,78 @@ warnMissingHomeModules hsc_env mod_graph =
-- `ghc --make -isrc-exe Main` are supposed to be equivalent.
-- Note also that we can't always infer the associated module name
-- directly from the filename argument. See #13727.
- is_my_target mod (TargetModule name)
- = moduleName (ms_mod mod) == name
- is_my_target mod (TargetFile target_file _)
- | Just mod_file <- ml_hs_file (ms_location mod)
- = target_file == mod_file ||
-
- -- Don't warn on B.hs-boot if B.hs is specified (#16551)
- addBootSuffix target_file == mod_file ||
-
- -- We can get a file target even if a module name was
- -- originally specified in a command line because it can
- -- be converted in guessTarget (by appending .hs/.lhs).
- -- So let's convert it back and compare with module name
- mkModuleName (fst $ splitExtension target_file)
- == moduleName (ms_mod mod)
- is_my_target _ _ = False
+ is_my_target mod target =
+ let tuid = targetUnitId target
+ in case targetId target of
+ TargetModule name
+ -> moduleName (ms_mod mod) == name
+ && tuid == ms_unitid mod
+ TargetFile target_file _
+ | Just mod_file <- ml_hs_file (ms_location mod)
+ ->
+ target_file == mod_file ||
+
+ -- Don't warn on B.hs-boot if B.hs is specified (#16551)
+ addBootSuffix target_file == mod_file ||
+
+ -- We can get a file target even if a module name was
+ -- originally specified in a command line because it can
+ -- be converted in guessTarget (by appending .hs/.lhs).
+ -- So let's convert it back and compare with module name
+ mkModuleName (fst $ splitExtension target_file)
+ == moduleName (ms_mod mod)
+ _ -> False
missing = map (moduleName . ms_mod) $
- filter (not . is_known_module) (mgModSummaries mod_graph)
+ filter (not . is_known_module) $
+ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)
+ (mgModSummaries mod_graph))
warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
$ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)
+-- Check that any modules we want to reexport or hide are actually in the package.
+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
+warnUnknownModules hsc_env dflags mod_graph = do
+ reexported_warns <- filterM check_reexport (Set.toList reexported_mods)
+ return $ final_msgs hidden_warns reexported_warns
+ where
+ diag_opts = initDiagOpts dflags
+
+ unit_mods = Set.fromList (map ms_mod_name
+ (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)
+ (mgModSummaries mod_graph)))
+
+ reexported_mods = reexportedModules dflags
+ hidden_mods = hiddenModules dflags
+
+ hidden_warns = hidden_mods `Set.difference` unit_mods
+
+ lookupModule mn = findImportedModule hsc_env mn NoPkgQual
+
+ check_reexport mn = do
+ fr <- lookupModule mn
+ case fr of
+ Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)
+ _ -> return True
+
+
+ warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
+ $ flag mod
+
+ final_msgs hidden_warns reexported_warns
+ =
+ unionManyMessages $
+ [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]
+ ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]
+
-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
= LoadAllTargets
-- ^ Load all targets and its dependencies.
- | LoadUpTo ModuleName
+ | LoadUpTo HomeUnitModule
-- ^ Load only the given module and its dependencies.
- | LoadDependenciesOf ModuleName
+ | LoadDependenciesOf HomeUnitModule
-- ^ Load only the dependencies of the given module, but not the module
-- itself.
@@ -352,10 +430,18 @@ data LoadHowMuch
load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
load how_much = fst <$> loadWithCache [] how_much
+mkBatchMsg :: HscEnv -> Messager
+mkBatchMsg hsc_env =
+ if length (hsc_all_home_unit_ids hsc_env) > 1
+ -- This also displays what unit each module is from.
+ then batchMultiMsg
+ else batchMsg
+
loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])
loadWithCache cache how_much = do
(errs, mod_graph) <- depanalE [] False -- #17459
- success <- load' cache how_much (Just batchMsg) mod_graph
+ msg <- mkBatchMsg <$> getSession
+ success <- load' cache how_much (Just msg) mod_graph
if isEmptyMessages errs
then pure success
else throwErrors (fmap GhcDriverMessage errs)
@@ -367,22 +453,20 @@ loadWithCache cache how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: HscEnv -> ModuleGraph -> DriverMessages
-warnUnusedPackages hsc_env mod_graph =
- let dflags = hsc_dflags hsc_env
- state = hsc_units hsc_env
- diag_opts = initDiagOpts dflags
- us = hsc_units hsc_env
+warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us dflags mod_graph =
+ let diag_opts = initDiagOpts dflags
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
- $ concatMap ms_imps (mgModSummaries mod_graph)
+ $ concatMap ms_imps (
+ filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))
requestedArgs = mapMaybe packageArg (packageFlags dflags)
unusedArgs
- = filter (\arg -> not $ any (matching state arg) loadedPackages)
+ = filter (\arg -> not $ any (matching us arg) loadedPackages)
requestedArgs
warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)
@@ -441,7 +525,7 @@ countMods (ResolvedCycle ns) = length ns
countMods (UnresolvedCycle ns) = length ns
-- See Note [Upsweep] for a high-level description.
-createBuildPlan :: ModuleGraph -> Maybe ModuleName -> [BuildPlan]
+createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
createBuildPlan mod_graph maybe_top_mod =
let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod
@@ -466,22 +550,24 @@ createBuildPlan mod_graph maybe_top_mod =
(mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)
trans_deps_map = allReachable mg (mkNodeKey . node_payload)
- boot_path mn =
+ boot_path mn uid =
map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $
- Set.delete (NodeKey_Module (GWIB mn IsBoot)) $
- expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn NotBoot)) trans_deps_map)
- `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (GWIB mn IsBoot)) trans_deps_map))
+ Set.delete (NodeKey_Module (key IsBoot)) $
+ expectJust "boot_path" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)
+ `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (key IsBoot)) trans_deps_map))
+ where
+ key ib = ModNodeKeyWithUid (GWIB mn ib) uid
-- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists
boot_modules = mkModuleEnv
- [ (ms_mod ms, (m, boot_path (ms_mod_name ms))) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
+ [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
select_boot_modules = mapMaybe (fmap fst . get_boot_module)
get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))
- get_boot_module m = case m of ModuleNode (ExtendedModSummary ms _) | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
+ get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
-- Any cycles should be resolved now
collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
@@ -512,7 +598,7 @@ createBuildPlan mod_graph maybe_top_mod =
in
assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))
- (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr build_plan), (text "GRAPH:" <+> ppr (mgModSummaries' mod_graph ))])
+ (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])
build_plan
-- | Generalized version of 'load' which also supports a custom
@@ -533,7 +619,7 @@ load' cache how_much mHscMessage mod_graph = do
-- The downsweep should have ensured this does not happen
-- (see msDeps)
let all_home_mods =
- mkUniqSet [ ms_mod_name s
+ Set.fromList [ Module (ms_unitid s) (ms_mod_name s)
| s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]
-- TODO: Figure out what the correct form of this assert is. It's violated
-- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
@@ -549,10 +635,10 @@ load' cache how_much mHscMessage mod_graph = do
checkHowMuch _ = id
checkMod m and_then
- | m `elementOfUniqSet` all_home_mods = and_then
+ | m `Set.member` all_home_mods = and_then
| otherwise = do
liftIO $ errorMsg logger
- (text "no such module:" <+> quotes (ppr m))
+ (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))
return (Failed, [])
checkHowMuch how_much $ do
@@ -574,8 +660,6 @@ load' cache how_much mHscMessage mod_graph = do
build_plan = createBuildPlan mod_graph maybe_top_mod
-
-
let
-- prune the HPT so everything is not retained when doing an
-- upsweep.
@@ -586,7 +670,9 @@ load' cache how_much mHscMessage mod_graph = do
-- before we unload anything, make sure we don't leave an old
-- interactive context around pointing to dead bindings. Also,
-- write an empty HPT to allow the old HPT to be GC'd.
- setSession $ discardIC $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
+
+ let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }
+ setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
-- Unload everything
liftIO $ unload interp hsc_env
@@ -596,103 +682,33 @@ load' cache how_much mHscMessage mod_graph = do
let direct_deps = mkDepsMap (mgModSummaries' mod_graph)
- n_jobs <- case parMakeCount dflags of
+ n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
Nothing -> liftIO getNumProcessors
Just n -> return n
- setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
+ setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
hsc_env <- getSession
(upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $
liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) direct_deps build_plan
setSession hsc_env1
fmap (, new_cache) $ case upsweep_ok of
- Failed -> loadFinish upsweep_ok Succeeded
-
+ Failed -> loadFinish upsweep_ok
Succeeded -> do
- -- Make modsDone be the summaries for each home module now
- -- available; this should equal the domain of hpt3.
- -- Get in in a roughly top .. bottom order (hence reverse).
-
- -- Try and do linking in some form, depending on whether the
- -- upsweep was completely or only partially successful.
-
- -- Easy; just relink it all.
- do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
-
+ liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
- hsc_env1 <- getSession
liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags
+ loadFinish upsweep_ok
- -- Issue a warning for the confusing case where the user
- -- said '-o foo' but we're not going to do any linking.
- -- We attempt linking if either (a) one of the modules is
- -- called Main, or (b) the user said -no-hs-main, indicating
- -- that main() is going to come from somewhere else.
- --
- let ofile = outputFile_ dflags
- let no_hs_main = gopt Opt_NoHsMain dflags
- let
- main_mod = mainModIs hsc_env
- a_root_is_Main = mgElemModule mod_graph main_mod
- do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
-
- -- link everything together
- hsc_env <- getSession
- linkresult <- liftIO $ link (ghcLink dflags)
- logger
- (hsc_tmpfs hsc_env)
- (hsc_hooks hsc_env)
- dflags
- (hsc_unit_env hsc_env)
- do_linking
- (hsc_HPT hsc_env1)
-
- if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
- then do
- liftIO $ errorMsg logger $ text
- ("output was redirected with -o, " ++
- "but no output will be generated\n" ++
- "because there is no " ++
- moduleNameString (moduleName main_mod) ++ " module.")
- -- This should be an error, not a warning (#10895).
- loadFinish Failed linkresult
- else
- loadFinish Succeeded linkresult
-
-partitionNodes
- :: [ModuleGraphNode]
- -> ( [InstantiatedUnit]
- , [ExtendedModSummary]
- )
-partitionNodes ns = partitionEithers $ flip fmap ns $ \case
- InstantiationNode x -> Left x
- ModuleNode x -> Right x
-
--- | Finish up after a load.
-loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
--- If the link failed, unload everything and return.
-loadFinish _all_ok Failed
- = do hsc_env <- getSession
- let interp = hscInterp hsc_env
- liftIO $ unload interp hsc_env
- modifySession discardProg
- return Failed
+-- | Finish up after a load.
+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
-loadFinish all_ok Succeeded
+loadFinish all_ok
= do modifySession discardIC
return all_ok
-
--- | Forget the current program, but retain the persistent info in HscEnv
-discardProg :: HscEnv -> HscEnv
-discardProg hsc_env
- = discardIC
- $ hscUpdateHPT (const emptyHomePackageTable)
- $ hsc_env { hsc_mod_graph = emptyMG }
-
-- | Discard the contents of the InteractiveContext, but keep the DynFlags and
-- the loaded plugins. It will also keep ic_int_print and ic_monad if their
-- names are from external packages.
@@ -721,34 +737,42 @@ discardIC hsc_env
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
guessOutputFile = modifySession $ \env ->
- let dflags = hsc_dflags env
- platform = targetPlatform dflags
- -- Force mod_graph to avoid leaking env
- !mod_graph = hsc_mod_graph env
- mainModuleSrcPath :: Maybe String
- mainModuleSrcPath = do
- ms <- mgLookupModule mod_graph (mainModIs env)
- ml_hs_file (ms_location ms)
- name = fmap dropExtension mainModuleSrcPath
-
- !name_exe = do
- -- we must add the .exe extension unconditionally here, otherwise
- -- when name has an extension of its own, the .exe extension will
- -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248
- !name' <- if platformOS platform == OSMinGW32
- then fmap (<.> "exe") name
- else name
- mainModuleSrcPath' <- mainModuleSrcPath
- -- #9930: don't clobber input files (unless they ask for it)
- if name' == mainModuleSrcPath'
- then throwGhcException . UsageError $
- "default output name would overwrite the input file; " ++
- "must specify -o explicitly"
- else Just name'
- in
- case outputFile_ dflags of
- Just _ -> env
- Nothing -> hscSetFlags (dflags { outputFile_ = name_exe }) env
+ -- Force mod_graph to avoid leaking env
+ let !mod_graph = hsc_mod_graph env
+ new_home_graph =
+ flip unitEnv_map (hsc_HUG env) $ \hue ->
+ let dflags = homeUnitEnv_dflags hue
+ platform = targetPlatform dflags
+ mainModuleSrcPath :: Maybe String
+ mainModuleSrcPath = do
+ ms <- mgLookupModule mod_graph (mainModIs hue)
+ ml_hs_file (ms_location ms)
+ name = fmap dropExtension mainModuleSrcPath
+
+ -- MP: This exception is quite sensitive to being forced, if you
+ -- force it here then the error message is different because it gets
+ -- caught by a different error handler than the test (T9930fail) expects.
+ -- Putting an exception into DynFlags is probably not a great design but
+ -- I'll write this comment rather than more eagerly force the exception.
+ name_exe = do
+ -- we must add the .exe extension unconditionally here, otherwise
+ -- when name has an extension of its own, the .exe extension will
+ -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248
+ !name' <- if platformOS platform == OSMinGW32
+ then fmap (<.> "exe") name
+ else name
+ mainModuleSrcPath' <- mainModuleSrcPath
+ -- #9930: don't clobber input files (unless they ask for it)
+ if name' == mainModuleSrcPath'
+ then throwGhcException . UsageError $
+ "default output name would overwrite the input file; " ++
+ "must specify -o explicitly"
+ else Just name'
+ in
+ case outputFile_ dflags of
+ Just _ -> hue
+ Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }
+ in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }
-- -----------------------------------------------------------------------------
--
@@ -923,7 +947,7 @@ data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVa
-- the appropiate result of compiling a module but with
-- cycles there can be additional indirection and can point to the result of typechecking a loop
, nNODE :: Int
- , hpt_var :: MVar HomePackageTable
+ , hug_var :: MVar HomeUnitGraph
-- A global variable which is incrementally updated with the result
-- of compiling modules.
}
@@ -960,7 +984,7 @@ data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be au
-- For -j1, this wrapper doesn't do anything
-- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
-- into the log queue.
- , withLogger :: forall a . Int -> ((Logger -> Logger) -> RunMakeM a) -> RunMakeM a
+ , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
, env_messager :: !(Maybe Messager)
}
@@ -970,15 +994,16 @@ type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
-- get its direct dependencies from. This might not be the corresponding build action
-- if the module participates in a loop. This step also labels each node with a number for the output.
-- See Note [Upsweep] for a high-level description.
-interpretBuildPlan :: (M.Map ModuleNameWithIsBoot HomeModInfo)
+interpretBuildPlan :: HomeUnitGraph
+ -> M.Map ModNodeKeyWithUid HomeModInfo
-> (NodeKey -> [NodeKey])
-> [BuildPlan]
-> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle
, [MakeAction] -- Actions we need to run in order to build everything
, IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.
-interpretBuildPlan old_hpt deps_map plan = do
- hpt_var <- newMVar emptyHomePackageTable
- ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var)
+interpretBuildPlan hug old_hpt deps_map plan = do
+ hug_var <- newMVar hug
+ ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)
return (mcycle, plans, collect_results (buildDep build_map))
where
@@ -1016,28 +1041,35 @@ interpretBuildPlan old_hpt deps_map plan = do
buildSingleModule rehydrate_nodes mod = do
mod_idx <- nodeId
home_mod_map <- getBuildMap
- hpt_var <- gets hpt_var
+ hug_var <- gets hug_var
-- 1. Get the transitive dependencies of this module, by looking up in the dependency map
let direct_deps = deps_map (mkNodeKey mod)
- doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps
+ doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps
build_deps = map snd doc_build_deps
-- 2. Set the default way to build this node, not in a loop here
- let build_action = do
- hsc_env <- asks hsc_env
+ let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $
case mod of
- InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu
- ModuleNode ms -> do
- let !old_hmi = M.lookup (msKey $ emsModSummary ms) old_hpt
+ InstantiationNode uid iu ->
+ const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu
+ ModuleNode build_deps ms -> do
+ let !old_hmi = M.lookup (msKey ms) old_hpt
rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes
- hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hpt hpt_var build_deps) rehydrate_mods (emsModSummary ms)
+ build_deps_vars = map snd $ map (expectJust "build_deps" . flip M.lookup home_mod_map) build_deps
+ hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps_vars) rehydrate_mods ms
-- This global MVar is incrementally modified in order to avoid having to
-- recreate the HPT before compiling each module which leads to a quadratic amount of work.
- hmi' <- liftIO $ modifyMVar hpt_var (\hpt -> do
- let new_hpt = addHomeModInfoToHpt hmi hpt
- new_hsc = setHPT new_hpt hsc_env
+ hsc_env <- asks hsc_env
+ hmi' <- liftIO $ modifyMVar hug_var (\hug -> do
+ let new_hpt = addHomeModInfoToHug hmi hug
+ new_hsc = setHUG new_hpt hsc_env
maybeRehydrateAfter hmi new_hsc rehydrate_mods
)
return (Just hmi')
+ LinkNode nks uid -> do
+ let link_deps = map snd $ map (\nk -> expectJust "build_deps_link" . flip M.lookup home_mod_map $ nk) nks
+ executeLinkNode (wait_deps_hug hug_var link_deps) (mod_idx, n_mods) uid nks
+ return Nothing
+
res_var <- liftIO newEmptyMVar
let result_var = mkResultVar res_var
@@ -1049,7 +1081,7 @@ interpretBuildPlan old_hpt deps_map plan = do
buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =
buildSingleModule (Just deps) mn
- buildModuleLoop :: [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -> BuildM [MakeAction]
+ buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]
buildModuleLoop ms = do
(build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms
res_var <- liftIO newEmptyMVar
@@ -1060,21 +1092,26 @@ interpretBuildPlan old_hpt deps_map plan = do
-- module loop will see the updated interfaces for all the identifiers in the loop.
let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)
- let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModSum . either id getNode) ms) [0..]
+ let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..]
mapM update_module_pipeline ms_i
return $ build_modules ++ [MakeAction loop_action res_var]
+withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
+withCurrentUnit uid = do
+ local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})
+
+
upsweep
:: Int -- ^ The number of workers we wish to run in parallel
-> HscEnv -- ^ The base HscEnv, which is augmented for each module
-> Maybe Messager
- -> M.Map ModuleNameWithIsBoot HomeModInfo
+ -> M.Map ModNodeKeyWithUid HomeModInfo
-> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey
-> [BuildPlan]
-> IO (SuccessFlag, HscEnv, [HomeModInfo])
upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
- (cycle, pipelines, collect_result) <- interpretBuildPlan old_hpt direct_deps build_plan
+ (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt direct_deps build_plan
runPipelines n_jobs hsc_env mHscMessage pipelines
res <- collect_result
@@ -1092,18 +1129,22 @@ upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do
let success_flag = successIf (all isJust res)
return (success_flag, hsc_env', completed)
-toCache :: [HomeModInfo] -> M.Map ModuleNameWithIsBoot HomeModInfo
-toCache hmis = M.fromList ([(mi_mnwib $ hm_iface hmi, hmi) | hmi <- hmis])
+toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])
+
+miKey :: ModIface -> ModNodeKeyWithUid
+miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))
upsweep_inst :: HscEnv
-> Maybe Messager
-> Int -- index of module
-> Int -- total number of modules
+ -> UnitId
-> InstantiatedUnit
-> IO ()
-upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do
+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do
case mHscMessage of
- Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)
+ Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode uid iuid)
Nothing -> return ()
runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid
pure ()
@@ -1262,7 +1303,7 @@ topSortModuleGraph
:: Bool
-- ^ Drop hi-boot nodes? (see below)
-> ModuleGraph
- -> Maybe ModuleName
+ -> Maybe HomeUnitModule
-- ^ Root module name. If @Nothing@, use the full graph.
-> [SCC ModuleGraphNode]
-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
@@ -1284,7 +1325,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
-- the summaries we get a stable topological sort.
topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod
-topSortModules :: Bool -> [ModuleGraphNode] -> Maybe ModuleName -> [SCC ModuleGraphNode]
+topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModules drop_hs_boot_nodes summaries mb_root_mod
= map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
where
@@ -1293,29 +1334,18 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod
initial_graph = case mb_root_mod of
Nothing -> graph
- Just root_mod ->
+ Just (Module uid root_mod) ->
-- restrict the graph to just those modules reachable from
-- the specified module. We do this by building a graph with
-- the full set of nodes, and determining the reachable set from
-- the specified node.
- let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot
+ let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid
, graph `hasVertexG` node
= node
| otherwise
= throwGhcException (ProgramError "module does not exist")
in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
--- The nodes of the graph are keyed by (mod, is boot?) pairs for the current
--- modules, and indefinite unit IDs for dependencies which are instantiated with
--- our holes.
---
--- NB: hsig files show up as *normal* nodes (not boot!), since they don't
--- participate in cycles (for now)
-
-mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
-mkNodeMap summaries = ModNodeMap $ Map.fromList
- [ (ms_mnwib $ emsModSummary s, s) | s <- summaries]
-
newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }
deriving (Functor, Traversable, Foldable)
@@ -1331,6 +1361,12 @@ modNodeMapElems (ModNodeMap m) = Map.elems m
modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
modNodeMapLookup k (ModNodeMap m) = Map.lookup k m
+modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a
+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)
+
+modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)
+
-- | Efficiently construct a map from a NodeKey to its list of transitive dependencies
mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])
mkDepsMap nodes =
@@ -1358,6 +1394,10 @@ warnUnnecessarySourceImports sccs = do
logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))
+-- This caches the answer to the question, if we are in this unit, what does
+-- an import of this module mean.
+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
+
-----------------------------------------------------------------------------
--
-- | Downsweep (dependency analysis)
@@ -1374,69 +1414,95 @@ warnUnnecessarySourceImports sccs = do
-- module, plus one for any hs-boot files. The imports of these nodes
-- are all there, including the imports of non-home-package modules.
downsweep :: HscEnv
- -> [ExtendedModSummary]
+ -> [ModSummary]
-- ^ Old summaries
-> [ModuleName] -- Ignore dependencies on these; treat
-- them as if they were package modules
-> Bool -- True <=> allow multiple targets to have
-- the same module name; this is
-- very useful for ghc -M
- -> IO [Either DriverMessages ExtendedModSummary]
+ -> IO ([DriverMessages], [ModuleGraphNode])
-- The non-error elements of the returned list all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true in
-- which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= do
rootSummaries <- mapM getRootSummary roots
- let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
+ let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
root_map = mkRootMap rootSummariesOk
checkDuplicates root_map
- map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
+ (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
+ let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
+ let unit_env = hsc_unit_env hsc_env
+ let tmpfs = hsc_tmpfs hsc_env
+
+ let downsweep_errs = lefts $ concat $ M.elems map0
+ downsweep_nodes = M.elems deps
+
+ (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
+ all_nodes = downsweep_nodes ++ unit_nodes
+ all_errs = all_root_errs ++ downsweep_errs ++ other_errs
+ all_root_errs = closure_errs ++ map snd root_errs
+
-- if we have been passed -fno-code, we enable code generation
-- for dependencies of modules that have -XTemplateHaskell,
-- otherwise those modules will fail to compile.
-- See Note [-fno-code mode] #8025
- let default_backend = platformDefaultBackend (targetPlatform dflags)
- let home_unit = hsc_home_unit hsc_env
- let tmpfs = hsc_tmpfs hsc_env
- map1 <- case backend dflags of
- NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0
- _ -> return map0
- if null errs
- then pure $ concat $ modNodeMapElems map1
- else pure $ map Left errs
+ th_enabled_nodes <- case backend dflags of
+ NoBackend -> enableCodeGenForTH logger tmpfs unit_env all_nodes
+ _ -> return all_nodes
+ if null all_root_errs
+ then return (all_errs, th_enabled_nodes)
+ else pure $ (all_root_errs, [])
where
- -- TODO(@Ericson2314): Probably want to include backpack instantiations
- -- in the map eventually for uniformity
- calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms
+ -- Dependencies arising on a unit (backpack and module linking deps)
+ unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
+ unitModuleNodes summaries uid hue =
+ let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)
+ in map Right instantiation_nodes
+ ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)
+
+ calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
roots = hsc_targets hsc_env
- old_summary_map :: ModNodeMap ExtendedModSummary
- old_summary_map = mkNodeMap old_summaries
+ -- A cache from file paths to the already summarised modules.
+ -- Reuse these if we can because the most expensive part of downsweep is
+ -- reading the headers.
+ old_summary_map :: M.Map FilePath ModSummary
+ old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]
- getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary)
+ getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
getRootSummary Target { targetId = TargetFile file mb_phase
, targetContents = maybe_buf
+ , targetUnitId = uid
}
- = do exists <- liftIO $ doesFileExist file
+ = do let offset_file = augmentByWorkingDirectory dflags file
+ exists <- liftIO $ doesFileExist offset_file
if exists || isJust maybe_buf
- then summariseFile hsc_env old_summaries file mb_phase
+ then first (uid,) <$>
+ summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
maybe_buf
- else return $ Left $ singleMessage
- $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound file)
+ else return $ Left $ (uid,) $ singleMessage
+ $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
+ where
+ dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
getRootSummary Target { targetId = TargetModule modl
, targetContents = maybe_buf
+ , targetUnitId = uid
}
- = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
- (L rootLoc modl)
+ = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
+ (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
maybe_buf excl_mods
case maybe_summary of
- Nothing -> return $ Left $ moduleNotFoundErr modl
- Just s -> return s
-
+ FoundHome s -> return (Right s)
+ FoundHomeWithError err -> return (Left err)
+ _ -> return $ Left $ (uid, moduleNotFoundErr modl)
+ where
+ home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-- In a root module, the filename is allowed to diverge from the module
@@ -1444,53 +1510,134 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- defining the same module (otherwise the duplicates will be silently
-- ignored, leading to confusing behaviour).
checkDuplicates
- :: ModNodeMap
- [Either DriverMessages
- ExtendedModSummary]
+ :: DownsweepCache
-> IO ()
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
- | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)
+ | otherwise = liftIO $ multiRootsErr (head dup_roots)
where
- dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2
- dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map
+ dup_roots :: [[ModSummary]] -- Each at least of length 2
+ dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
+
+ -- 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, Set.Set (UnitId, UnitId),
+ DownsweepCache)
+ -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
+ loopSummaries [] done = return done
+ loopSummaries (ms:next) (done, pkgs, summarised)
+ | Just {} <- M.lookup k done
+ = loopSummaries next (done, pkgs, summarised)
+ -- Didn't work out what the imports mean yet, now do that.
+ | otherwise = do
+ (final_deps, pkgs1, 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 ms) done'', pkgs1 `Set.union` pkgs, summarised'')
+ where
+ k = NodeKey_Module (msKey ms)
+
+ hs_file_for_boot
+ | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
+ | otherwise = Nothing
+
- loop :: [GenWithIsBoot (Located ModuleName)]
+ -- 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, PkgQual, GenWithIsBoot (Located ModuleName))]
-- Work list: process these modules
- -> ModNodeMap [Either DriverMessages ExtendedModSummary]
+ -> 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 (ModNodeMap [Either DriverMessages ExtendedModSummary])
+ -> IO ([NodeKey], Set.Set (UnitId, UnitId),
+
+ M.Map NodeKey ModuleGraphNode, DownsweepCache)
-- The result is the completed NodeMap
- loop [] done = return done
- loop (s : ss) done
- | Just summs <- modNodeMapLookup key done
- = if isSingleton summs then
- loop ss done
- else
- do { multiRootsErr (emsModSummary <$> rights summs)
- ; return (ModNodeMap Map.empty)
- }
+ loopImports [] done summarised = return ([], Set.empty, done, summarised)
+ loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised
+ | Just summs <- M.lookup cache_key summarised
+ = case summs of
+ [Right ms] -> do
+ let nk = NodeKey_Module (msKey ms)
+ (rest, pkgs, summarised', done') <- loopImports ss done summarised
+ return (nk: rest, pkgs, summarised', done')
+ [Left _err] ->
+ loopImports ss done summarised
+ _errs -> do
+ loopImports ss done summarised
| otherwise
- = do mb_s <- summariseModule hsc_env old_summary_map
- is_boot wanted_mod
+ = do
+ mb_s <- summariseModule hsc_env home_unit old_summary_map
+ is_boot wanted_mod mb_pkg
Nothing excl_mods
case mb_s of
- Nothing -> loop ss done
- Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)
- Just (Right s)-> do
- new_map <-
- loop (calcDeps s) (modNodeMapInsert key [Right s] done)
- loop ss new_map
+ NotThere -> loopImports ss done summarised
+ External uid -> do
+ (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
+ return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')
+ FoundInstantiation iud -> do
+ (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
+ return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')
+ FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised)
+ FoundHome s -> do
+ (done', pkgs1, summarised') <-
+ loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)
+ (other_deps, pkgs2, 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 (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)
where
- GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s
+ 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
- key = GWIB
- { gwib_mod = unLoc wanted_mod
- , gwib_isBoot = is_boot
- }
+
+-- This function checks then important property that if both p and q are home units
+-- then any dependency of p, which transitively depends on q is also a home unit.
+checkHomeUnitsClosed :: UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
+-- Fast path, trivially closed.
+checkHomeUnitsClosed ue home_id_set home_imp_ids
+ | Set.size home_id_set == 1 = []
+ | otherwise =
+ let res = foldMap loop home_imp_ids
+ -- Now check whether everything which transitively depends on a home_unit is actually a home_unit
+ -- These units are the ones which we need to load as home packages but failed to do for some reason,
+ -- it's a bug in the tool invoking GHC.
+ bad_unit_ids = Set.difference res home_id_set
+ in if Set.null bad_unit_ids
+ then []
+ else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
+
+ where
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+ -- TODO: This could repeat quite a bit of work but I struggled to write this function.
+ -- Which units transitively depend on a home unit
+ loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit
+ loop (from_uid, uid) =
+ let us = ue_findHomeUnitEnv from_uid ue in
+ let um = unitInfoMap (homeUnitEnv_units us) in
+ case Map.lookup uid um of
+ Nothing -> pprPanic "uid not found" (ppr uid)
+ Just ui ->
+ let depends = unitDepends ui
+ home_depends = Set.fromList depends `Set.intersection` home_id_set
+ other_depends = Set.fromList depends `Set.difference` home_id_set
+ in
+ -- Case 1: The unit directly depends on a home_id
+ if not (null home_depends)
+ then
+ let res = foldMap (loop . (from_uid,)) other_depends
+ in Set.insert uid res
+ -- Case 2: Check the rest of the dependencies, and then see if any of them depended on
+ else
+ let res = foldMap (loop . (from_uid,)) other_depends
+ in
+ if not (Set.null res)
+ then Set.insert uid res
+ else res
-- | Update the every ModSummary that is depended on
-- by a module that needs template haskell. We enable codegen to
@@ -1500,19 +1647,18 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
enableCodeGenForTH
:: Logger
-> TmpFs
- -> HomeUnit
- -> Backend
- -> ModNodeMap [Either DriverMessages ExtendedModSummary]
- -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
-enableCodeGenForTH logger tmpfs home_unit =
- enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession
+ -> UnitEnv
+ -> [ModuleGraphNode]
+ -> IO [ModuleGraphNode]
+enableCodeGenForTH logger tmpfs unit_env =
+ enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession unit_env
where
condition = isTemplateHaskellOrQQNonBoot
- should_modify (ModSummary { ms_hspp_opts = dflags }) =
+ should_modify ms@(ModSummary { ms_hspp_opts = dflags }) =
backend dflags == NoBackend &&
-- Don't enable codegen for TH on indefinite packages; we
-- can't compile anything anyway! See #16219.
- isHomeUnitDefinite home_unit
+ isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
-- | Helper used to implement 'enableCodeGenForTH'.
-- In particular, this enables
@@ -1527,22 +1673,22 @@ enableCodeGenWhen
-> (ModSummary -> Bool)
-> TempFileLifetime
-> TempFileLifetime
- -> Backend
- -> ModNodeMap [Either DriverMessages ExtendedModSummary]
- -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary])
-enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =
- traverse (traverse (traverse enable_code_gen)) nodemap
+ -> UnitEnv
+ -> [ModuleGraphNode]
+ -> IO [ModuleGraphNode]
+enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_env mod_graph =
+ mapM enable_code_gen mod_graph
where
- enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary
- enable_code_gen (ExtendedModSummary ms bkp_deps)
+ defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
+ enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
+ enable_code_gen n@(ModuleNode deps ms)
| ModSummary
- { ms_mod = ms_mod
- , ms_location = ms_location
+ { ms_location = ms_location
, ms_hsc_src = HsSrcFile
, ms_hspp_opts = dflags
} <- ms
, should_modify ms
- , ms_mod `Set.member` needs_codegen_set
+ , mkNodeKey n `Set.member` needs_codegen_set
= do
let new_temp_file suf dynsuf = do
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
@@ -1567,65 +1713,28 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd
, ml_obj_file = o_file
, ml_dyn_hi_file = dyn_hi_file
, ml_dyn_obj_file = dyn_o_file }
- , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}
+ , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}
}
- pure (ExtendedModSummary ms' bkp_deps)
- | otherwise = return (ExtendedModSummary ms bkp_deps)
+ pure (ModuleNode deps ms')
+ enable_code_gen ms = return ms
+
+
+ (mg, lookup_node) = moduleGraphNodes False mod_graph
+ needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)
- needs_codegen_set = transitive_deps_set
- [ ms
- | mss <- modNodeMapElems nodemap
- , Right (ExtendedModSummary { emsModSummary = ms }) <- mss
+
+ has_th_set =
+ [ mkNodeKey mn
+ | mn@(ModuleNode _ ms) <- mod_graph
, condition ms
]
- -- find the set of all transitive dependencies of a list of modules.
- transitive_deps_set :: [ModSummary] -> Set.Set Module
- transitive_deps_set modSums = foldl' go Set.empty modSums
- where
- go marked_mods ms@ModSummary{ms_mod}
- | ms_mod `Set.member` marked_mods = marked_mods
- | otherwise =
- let deps =
- [ dep_ms
- -- If a module imports a boot module, msDeps helpfully adds a
- -- dependency to that non-boot module in it's result. This
- -- means we don't have to think about boot modules here.
- | dep <- msDeps ms
- , NotBoot == gwib_isBoot dep
- , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap
- , dep_ms_1 <- toList $ dep_ms_0
- , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1
- ]
- new_marked_mods = Set.insert ms_mod marked_mods
- in foldl' go new_marked_mods deps
-
+-- | Populate the Downsweep cache with the root modules.
mkRootMap
- :: [ExtendedModSummary]
- -> ModNodeMap [Either DriverMessages ExtendedModSummary]
-mkRootMap summaries = ModNodeMap $ Map.insertListWith
- (flip (++))
- [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]
- Map.empty
-
--- | Returns the dependencies of the ModSummary s.
--- A wrinkle is that for a {-# SOURCE #-} import we return
--- *both* the hs-boot file
--- *and* the source file
--- as "dependencies". That ensures that the list of all relevant
--- modules always contains B.hs if it contains B.hs-boot.
--- Remember, this pass isn't doing the topological sort. It's
--- just gathering the list of all relevant ModSummaries
-msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]
-msDeps s = [ d
- | m <- ms_home_srcimps s
- , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
- , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
- ]
- ]
- ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }
- | m <- ms_home_imps s
- ]
+ :: [ModSummary]
+ -> DownsweepCache
+mkRootMap summaries = Map.fromListWith (flip (++))
+ [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]
-----------------------------------------------------------------------------
-- Summarising modules
@@ -1642,19 +1751,20 @@ msDeps s = [ d
summariseFile
:: HscEnv
- -> [ExtendedModSummary] -- old summaries
+ -> HomeUnit
+ -> M.Map FilePath ModSummary -- old summaries
-> FilePath -- source file name
-> Maybe Phase -- start phase
-> Maybe (StringBuffer,UTCTime)
- -> IO (Either DriverMessages ExtendedModSummary)
+ -> IO (Either DriverMessages ModSummary)
-summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf
+summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
-- we can use a cached summary if one is available and the
-- source file hasn't changed, But we have to look up the summary
-- by source file, rather than module name as we do in summarise.
- | Just old_summary <- findSummaryBySourceFile old_summaries src_fn
+ | Just old_summary <- M.lookup src_fn old_summaries
= do
- let location = ms_location $ emsModSummary old_summary
+ let location = ms_location $ old_summary
src_hash <- get_src_hash
-- The file exists; we checked in getRootSummary above.
@@ -1671,6 +1781,8 @@ summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf
= do src_hash <- get_src_hash
new_summary src_fn src_hash
where
+ -- change the main active unit so all operations happen relative to the given unit
+ hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
-- src_fn does not necessarily exist on the filesystem, so we need to
-- check what kind of target we are dealing with
get_src_hash = case maybe_buf of
@@ -1706,26 +1818,14 @@ summariseFile hsc_env old_summaries src_fn mb_phase maybe_buf
, nms_preimps = preimps
}
-findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary
-findSummaryBySourceFile summaries file = case
- [ ms
- | ms <- summaries
- , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]
- , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms
- , expectJust "findSummaryBySourceFile" derived_file == file
- ]
- of
- [] -> Nothing
- (x:_) -> Just x
-
checkSummaryHash
:: HscEnv
- -> (Fingerprint -> IO (Either e ExtendedModSummary))
- -> ExtendedModSummary -> ModLocation -> Fingerprint
- -> IO (Either e ExtendedModSummary)
+ -> (Fingerprint -> IO (Either e ModSummary))
+ -> ModSummary -> ModLocation -> Fingerprint
+ -> IO (Either e ModSummary)
checkSummaryHash
hsc_env new_summary
- (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})
+ old_summary
location src_hash
| ms_hs_hash old_summary == src_hash &&
not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
@@ -1737,88 +1837,78 @@ checkSummaryHash
-- and it was likely flushed in depanal. This is not technically
-- needed when we're called from sumariseModule but it shouldn't
-- hurt.
+ -- Also, only add to finder cache for non-boot modules as the finder cache
+ -- makes sure to add a boot suffix for boot files.
_ <- 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
+ case ms_hsc_src old_summary of
+ HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location
+ _ -> return ()
hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
return $ Right
- ( ExtendedModSummary { emsModSummary = old_summary
+ ( old_summary
{ ms_obj_date = obj_timestamp
, ms_iface_date = hi_timestamp
, ms_hie_date = hie_timestamp
}
- , emsInstantiatedUnits = bkp_deps
- }
)
| otherwise =
-- source changed: re-summarise.
new_summary src_hash
+data SummariseResult =
+ FoundInstantiation InstantiatedUnit
+ | FoundHomeWithError (UnitId, DriverMessages)
+ | FoundHome ModSummary
+ | External UnitId
+ | NotThere
+
-- Summarise a module, and pick up source and timestamp.
summariseModule
:: HscEnv
- -> ModNodeMap ExtendedModSummary
+ -> HomeUnit
+ -> M.Map FilePath ModSummary
-- ^ Map of old summaries
-> IsBootInterface -- True <=> a {-# SOURCE #-} import
-> Located ModuleName -- Imported module to be summarised
+ -> PkgQual
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName] -- Modules to exclude
- -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary
+ -> IO SummariseResult
+
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+summariseModule hsc_env' home_unit old_summary_map is_boot (L loc wanted_mod) mb_pkg
maybe_buf excl_mods
| wanted_mod `elem` excl_mods
- = return Nothing
-
- | Just old_summary <- modNodeMapLookup
- (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })
- old_summary_map
- = do -- Find its new timestamp; all the
- -- ModSummaries in the old map have valid ml_hs_files
- let location = ms_location $ emsModSummary old_summary
- src_fn = expectJust "summariseModule" (ml_hs_file location)
-
- -- check the hash on the source file, and
- -- return the cached summary if it hasn't changed. If the
- -- file has disappeared, we need to call the Finder again.
- case maybe_buf of
- Just (buf,_) ->
- Just <$> check_hash old_summary location src_fn (fingerprintStringBuffer buf)
- Nothing -> do
- mb_hash <- fileHashIfExists src_fn
- case mb_hash of
- Just hash -> Just <$> check_hash old_summary location src_fn hash
- Nothing -> find_it
-
+ = return NotThere
| otherwise = find_it
where
- dflags = hsc_dflags hsc_env
- fopts = initFinderOpts dflags
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- fc = hsc_FC hsc_env
- units = hsc_units hsc_env
+ -- Temporarily change the currently active home unit so all operations
+ -- happen relative to it
+ hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
+ dflags = hsc_dflags hsc_env
- check_hash old_summary location src_fn =
- checkSummaryHash
- hsc_env
- (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)
- old_summary location
+ find_it :: IO SummariseResult
find_it = do
- found <- findImportedModule fc fopts units mhome_unit wanted_mod NoPkgQual
+ found <- findImportedModule hsc_env wanted_mod mb_pkg
case found of
Found location mod
- | isJust (ml_hs_file location) ->
+ | isJust (ml_hs_file location) -> do
-- Home package
- Just <$> just_found location mod
-
- _ -> return Nothing
+ fresult <- just_found location mod
+ return $ case fresult of
+ Left err -> FoundHomeWithError (moduleUnitId mod, err)
+ Right ms -> FoundHome ms
+ | VirtUnit iud <- moduleUnit mod
+ , not (isHomeModule home_unit mod)
+ -> return $ FoundInstantiation iud
+ | otherwise -> return $ External (moduleUnitId mod)
+ _ -> return NotThere
-- Not found
-- (If it is TRULY not found at all, we'll
-- error when we actually try to compile)
@@ -1836,12 +1926,32 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
maybe_h <- fileHashIfExists src_fn
case maybe_h of
Nothing -> return $ Left $ noHsFileErr loc src_fn
- Just h -> new_summary location' mod src_fn h
+ Just h -> new_summary_cache_check location' mod src_fn h
+ new_summary_cache_check loc mod src_fn h
+ | Just old_summary <- Map.lookup src_fn old_summary_map =
+
+ -- check the hash on the source file, and
+ -- return the cached summary if it hasn't changed. If the
+ -- file has changed then need to resummarise.
+ case maybe_buf of
+ Just (buf,_) ->
+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
+ Nothing ->
+ checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
+ | otherwise = new_summary loc mod src_fn h
+
+ new_summary :: ModLocation
+ -> Module
+ -> FilePath
+ -> Fingerprint
+ -> IO (Either DriverMessages ModSummary)
new_summary location mod src_fn src_hash
= runExceptT $ do
preimps@PreprocessedImports {..}
- <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
+ -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
+ -- See multiHomeUnits_cpp2 test
+ <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
-- NB: Despite the fact that is_boot is a top-level parameter, we
-- don't actually know coming into this function what the HscSource
@@ -1859,7 +1969,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
$ DriverFileModuleNameMismatch pi_mod_name wanted_mod
- let instantiations = fromMaybe [] (homeUnitInstantiations <$> mhome_unit)
+ let instantiations = homeUnitInstantiations home_unit
when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
$ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
@@ -1887,7 +1997,7 @@ data MakeNewModSummary
, nms_preimps :: PreprocessedImports
}
-makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary
+makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
makeNewModSummary hsc_env MakeNewModSummary{..} = do
let PreprocessedImports{..} = nms_preimps
obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)
@@ -1896,10 +2006,9 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
- (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps
+ (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
- return $ ExtendedModSummary
- { emsModSummary =
+ return $
ModSummary
{ ms_mod = nms_mod
, ms_hsc_src = nms_hsc_src
@@ -1920,8 +2029,6 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
, ms_obj_date = obj_timestamp
, ms_dyn_obj_date = dyn_obj_timestamp
}
- , emsInstantiatedUnits = inst_deps
- }
data PreprocessedImports
= PreprocessedImports
@@ -2012,8 +2119,7 @@ noHsFileErr loc path
= singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)
moduleNotFoundErr :: ModuleName -> DriverMessages
-moduleNotFoundErr mod
- = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)
+moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)
multiRootsErr :: [ModSummary] -> IO ()
multiRootsErr [] = panic "multiRootsErr"
@@ -2032,10 +2138,7 @@ cyclicModuleErr mss
case findCycle graph of
Nothing -> text "Unexpected non-cycle" <+> ppr mss
Just path0 -> vcat
- [ case partitionNodes path0 of
- ([],_) -> text "Module imports form a cycle:"
- (_,[]) -> text "Module instantiations form a cycle:"
- _ -> text "Module imports and instantiations form a cycle:"
+ [ text "Module graph contains a cycle:"
, nest 2 (show_path path0)]
where
graph :: [Node NodeKey ModuleGraphNode]
@@ -2043,25 +2146,11 @@ cyclicModuleErr mss
[ DigraphNode
{ node_payload = ms
, node_key = mkNodeKey ms
- , node_dependencies = get_deps ms
+ , node_dependencies = nodeDependencies False ms
}
| ms <- mss
]
- get_deps :: ModuleGraphNode -> [NodeKey]
- get_deps = \case
- InstantiationNode iuid ->
- [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }
- | hole <- uniqDSetToList $ instUnitHoles iuid
- ]
- ModuleNode (ExtendedModSummary ms bds) ->
- [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }
- | m <- ms_home_srcimps ms ] ++
- [ NodeKey_Unit inst_unit
- | inst_unit <- bds ] ++
- [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }
- | m <- ms_home_imps ms ]
-
show_path :: [ModuleGraphNode] -> SDoc
show_path [] = panic "show_path"
show_path [m] = ppr_node m <+> text "imports itself"
@@ -2073,8 +2162,9 @@ cyclicModuleErr mss
go (m:ms) = (text "which imports" <+> ppr_node m) : go ms
ppr_node :: ModuleGraphNode -> SDoc
- ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)
- ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u
+ ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m
+ ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u
+ ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)
ppr_ms :: ModSummary -> SDoc
ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
@@ -2089,12 +2179,16 @@ cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv
addDepsToHscEnv deps hsc_env =
- hscUpdateHPT (const $ listHMIToHpt deps) hsc_env
+ hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env
setHPT :: HomePackageTable -> HscEnv -> HscEnv
setHPT deps hsc_env =
hscUpdateHPT (const $ deps) hsc_env
+setHUG :: HomeUnitGraph -> HscEnv -> HscEnv
+setHUG deps hsc_env =
+ hscUpdateHUG (const $ deps) hsc_env
+
-- | Wrap an action to catch and handle exceptions.
wrapAction :: HscEnv -> IO a -> IO (Maybe a)
wrapAction hsc_env k = do
@@ -2119,9 +2213,9 @@ wrapAction hsc_env k = do
_ -> errorMsg lcl_logger (text (show exc))
return Nothing
-withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> RunMakeM b) -> RunMakeM b
+withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
withParLog lqq_var k cont = do
- let init_log = liftIO $ do
+ let init_log = do
-- Make a new log queue
lq <- newLogQueue k
-- Add it into the LogQueueQueue
@@ -2130,49 +2224,49 @@ withParLog lqq_var k cont = do
finish_log lq = liftIO (finishLogQueue lq)
MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))
-withLoggerHsc :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a
-withLoggerHsc k cont = do
- MakeEnv{withLogger, hsc_env} <- ask
+withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do
withLogger k $ \modifyLogger -> do
let lcl_logger = modifyLogger (hsc_logger hsc_env)
hsc_env' = hsc_env { hsc_logger = lcl_logger }
-- Run continuation with modified logger
cont hsc_env'
--- Executing compilation graph nodes
executeInstantiationNode :: Int
-> Int
- -> RunMakeM HomePackageTable
+ -> RunMakeM HomeUnitGraph
+ -> UnitId
-> InstantiatedUnit
-> RunMakeM ()
-executeInstantiationNode k n wait_deps iu = do
- withLoggerHsc k $ \hsc_env -> do
+executeInstantiationNode k n wait_deps uid iu = do
-- Wait for the dependencies of this node
deps <- wait_deps
+ env <- ask
-- Output of the logger is mediated by a central worker to
-- avoid output interleaving
- let lcl_hsc_env = setHPT deps hsc_env
msg <- asks env_messager
- lift $ MaybeT $ wrapAction lcl_hsc_env $ do
- res <- upsweep_inst lcl_hsc_env msg k n iu
- cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
- return res
+ lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->
+ let lcl_hsc_env = setHUG deps hsc_env
+ in wrapAction lcl_hsc_env $ do
+ res <- upsweep_inst lcl_hsc_env msg k n uid iu
+ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
+ return res
executeCompileNode :: Int
-> Int
-> Maybe HomeModInfo
- -> RunMakeM HomePackageTable
+ -> RunMakeM HomeUnitGraph
-> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling
-> ModSummary
-> RunMakeM HomeModInfo
executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do
- MakeEnv{..} <- ask
- deps <- wait_deps
- -- Rehydrate any dependencies if this module had a boot file or is a signature file.
- withLoggerHsc k $ \hsc_env -> do
- hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHPT deps hsc_env) mod fixed_mrehydrate_mods
+ me@MakeEnv{..} <- ask
+ deps <- wait_deps
+ -- Rehydrate any dependencies if this module had a boot file or is a signature file.
+ lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do
+ hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods
let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
lcl_dynflags = ms_hspp_opts mod
let lcl_hsc_env =
@@ -2181,7 +2275,7 @@ executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do
hydrated_hsc_env
-- Compile the module, locking with a semphore to avoid too many modules
-- being compiled at the same time leading to high memory usage.
- lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do
+ wrapAction lcl_hsc_env $ do
res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
return res)
@@ -2238,14 +2332,14 @@ maybeRehydrateBefore hsc_env mod (Just mns) = do
maybeRehydrateAfter :: HomeModInfo
-> HscEnv
-> Maybe [ModuleName]
- -> IO (HomePackageTable, HomeModInfo)
-maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HPT new_hsc, hmi)
+ -> IO (HomeUnitGraph, HomeModInfo)
+maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi)
maybeRehydrateAfter hmi new_hsc (Just mns) = do
let new_hpt = hsc_HPT new_hsc
hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns
new_mod_name = moduleName (mi_module (hm_iface hmi))
- final_hpt <- hsc_HPT <$> rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)
- return (final_hpt, expectJust "rehydrate" $ lookupHpt final_hpt new_mod_name)
+ hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)
+ return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name)
{-
Note [Hydrating Modules]
@@ -2373,12 +2467,35 @@ Also closely related are
-}
+executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
+executeLinkNode wait_deps kn uid deps = do
+ withCurrentUnit uid $ do
+ MakeEnv{..} <- ask
+ hug <- wait_deps
+ let dflags = hsc_dflags hsc_env
+ let hsc_env' = setHUG hug hsc_env
+ msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager
+
+ linkresult <- liftIO $ withAbstractSem compile_sem $ do
+ link (ghcLink dflags)
+ (hsc_logger hsc_env')
+ (hsc_tmpfs hsc_env')
+ (hsc_hooks hsc_env')
+ dflags
+ (hsc_unit_env hsc_env')
+ True -- We already decided to link
+ msg'
+ (hsc_HPT hsc_env')
+ case linkresult of
+ Failed -> fail "Link Failed"
+ Succeeded -> return ()
+
-- | Wait for some dependencies to finish and then read from the given MVar.
-wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
-wait_deps_hpt hpt_var deps = do
+wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
+wait_deps_hug hug_var deps = do
_ <- wait_deps deps
- liftIO $ readMVar hpt_var
+ liftIO $ readMVar hug_var
-- | Wait for dependencies to finish, and then return their results.
@@ -2394,27 +2511,6 @@ wait_deps (x:xs) = do
-- Executing the pipelines
-- | Start a thread which reads from the LogQueueQueue
-logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
- -> TVar LogQueueQueue -- Queue for logs
- -> IO (IO ())
-logThread logger stopped lqq_var = do
- finished_var <- newEmptyMVar
- _ <- forkIO $ print_logs *> putMVar finished_var ()
- return (takeMVar finished_var)
- where
- finish = mapM (printLogs logger)
-
- print_logs = join $ atomically $ do
- lqq <- readTVar lqq_var
- case dequeueLogQueueQueue lqq of
- Just (lq, lqq') -> do
- writeTVar lqq_var lqq'
- return (printLogs logger lq *> print_logs)
- Nothing -> do
- -- No log to print, check if we are finished.
- stopped <- readTVar stopped
- if not stopped then retry
- else return (finish (allLogQueues lqq))
label_self :: String -> IO ()
@@ -2458,7 +2554,7 @@ runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do
-- will add it's LogQueue into this queue.
log_queue_queue_var <- newTVarIO newLogQueueQueue
-- Thread which coordinates the printing of logs
- wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var
+ wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var
-- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index ffe5a73399..a461ead22c 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -16,7 +16,6 @@ where
import GHC.Prelude
import qualified GHC
-import GHC.Driver.Config.Finder
import GHC.Driver.Monad
import GHC.Driver.Session
import GHC.Driver.Ppr
@@ -36,7 +35,6 @@ import GHC.Utils.TmpFs
import GHC.Iface.Load (cannotFindModule)
-import GHC.Unit.Env
import GHC.Unit.Module
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
@@ -216,14 +214,15 @@ processDeps dflags _ _ _ _ (CyclicSCC nodes)
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $ GHC.cyclicModuleErr nodes
-processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))
+processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
= -- There shouldn't be any backpack instantiations; report them as well
throwGhcExceptionIO $ ProgramError $
showSDoc dflags $
vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
, nest 2 $ ppr node ]
+processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))
+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
= do { let extra_suffixes = depSuffixes dflags
include_pkg_deps = depIncludePkgDeps dflags
src_file = msHsFilePath node
@@ -291,14 +290,9 @@ findDependency :: HscEnv
-> Bool -- Record dependency on package modules
-> IO (Maybe FilePath) -- Interface file
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
- let fc = hsc_FC hsc_env
- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- let units = hsc_units hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
-- Find the module; this will be fast because
-- we've done it once during downsweep
- r <- findImportedModule fc fopts units mhome_unit imp pkg
+ r <- findImportedModule hsc_env imp pkg
case r of
Found loc _
-- Home package: just depend on the .hi or hi-boot file
@@ -395,10 +389,9 @@ dumpModCycles logger module_graph
| otherwise
= putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)
where
- topoSort = filterToposortToModules $
- GHC.topSortModuleGraph True module_graph Nothing
+ topoSort = GHC.topSortModuleGraph True module_graph Nothing
- cycles :: [[ModSummary]]
+ cycles :: [[ModuleGraphNode]]
cycles =
[ c | CyclicSCC c <- topoSort ]
@@ -406,14 +399,16 @@ dumpModCycles logger module_graph
$$ pprCycle c $$ blankLine
| (n,c) <- [1..] `zip` cycles ]
-pprCycle :: [ModSummary] -> SDoc
+pprCycle :: [ModuleGraphNode] -> SDoc
-- Print a cycle, but show only the imports within the cycle
pprCycle summaries = pp_group (CyclicSCC summaries)
where
cycle_mods :: [ModuleName] -- The modules in this cycle
- cycle_mods = map (moduleName . ms_mod) summaries
+ cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]
- pp_group (AcyclicSCC ms) = pp_ms ms
+ pp_group :: SCC ModuleGraphNode -> SDoc
+ pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms
+ pp_group (AcyclicSCC _) = empty
pp_group (CyclicSCC mss)
= assert (not (null boot_only)) $
-- The boot-only list must be non-empty, else there would
@@ -422,14 +417,15 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
pp_ms loop_breaker $$ vcat (map pp_group groups)
where
(boot_only, others) = partition is_boot_only mss
- is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
+ is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))
+ is_boot_only _ = False
in_group (L _ m) = m `elem` group_mods
- group_mods = map (moduleName . ms_mod) mss
+ group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]
- loop_breaker = head boot_only
+ loop_breaker = head ([ms | ModuleNode _ ms <- boot_only])
all_others = tail boot_only ++ others
- groups = filterToposortToModules $
- GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing
+ groups =
+ GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
<+> (pp_imps empty (map snd (ms_imps summary)) $$
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 22bd9c3280..3aaf9f298e 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -75,6 +75,7 @@ import GHC.Utils.TmpFs
import GHC.Linker.ExtraObj
import GHC.Linker.Static
+import GHC.Linker.Static.Utils
import GHC.Linker.Types
import GHC.Utils.Outputable
@@ -121,6 +122,7 @@ import Data.Either ( partitionEithers )
import qualified Data.Set as Set
import Data.Time ( getCurrentTime )
+import GHC.Iface.Recomp
-- Simpler type synonym for actions in the pipeline monad
type P m = TPipelineClass TPhase m
@@ -301,10 +303,12 @@ compileOne' mHscMessage
= (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp)
| otherwise
= (backend dflags, dflags2)
- dflags = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }
+ -- Note [Filepaths and Multiple Home Units]
+ dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
upd_summary = summary { ms_hspp_opts = dflags }
hsc_env = hscSetFlags dflags hsc_env0
+
-- ---------------------------------------------------------------------------
-- Link
--
@@ -364,6 +368,7 @@ link :: GhcLink -- ^ interactive or batch
-> DynFlags -- ^ dynamic flags
-> UnitEnv -- ^ unit environment
-> Bool -- ^ attempt linking in batch mode?
+ -> Maybe (RecompileRequired -> IO ())
-> HomePackageTable -- ^ what to link
-> IO SuccessFlag
@@ -374,7 +379,7 @@ link :: GhcLink -- ^ interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =
+link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =
case linkHook hooks of
Nothing -> case ghcLink of
NoLink -> return Succeeded
@@ -390,7 +395,7 @@ link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =
-> panicBadLink LinkInMemory
Just h -> h ghcLink dflags batch_attempt_linking hpt
where
- normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking hpt
+ normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt
panicBadLink :: GhcLink -> a
@@ -402,10 +407,11 @@ link' :: Logger
-> DynFlags -- ^ dynamic flags
-> UnitEnv -- ^ unit environment
-> Bool -- ^ attempt linking in batch mode?
+ -> Maybe (RecompileRequired -> IO ())
-> HomePackageTable -- ^ what to link
-> IO SuccessFlag
-link' logger tmpfs dflags unit_env batch_attempt_linking hpt
+link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
| batch_attempt_linking
= do
let
@@ -439,12 +445,12 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt
linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
- if not (gopt Opt_ForceRecomp dflags) && not linking_needed
+ forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed
+ if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate)
then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")
return Succeeded
else do
- compilationProgressMsg logger (text "Linking " <> text exe_file <> text " ...")
-- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of
@@ -465,7 +471,7 @@ link' logger tmpfs dflags unit_env batch_attempt_linking hpt
return Succeeded
-linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool
+linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired
linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
-- if the modification time on the executable is later than the
-- modification times on all of the objects and libraries, then omit
@@ -475,7 +481,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
exe_file = exeFileName platform staticLink (outputFile_ dflags)
e_exe_time <- tryIO $ getModificationUTCTime exe_file
case e_exe_time of
- Left _ -> return True
+ Left _ -> return MustCompile
Right t -> do
-- first check object files and extra_ld_inputs
let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
@@ -483,7 +489,7 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
let (errs,extra_times) = partitionEithers e_extra_times
let obj_times = map linkableTime linkables ++ extra_times
if not (null errs) || any (t <) obj_times
- then return True
+ then return (RecompBecause ObjectsChanged)
else do
-- next, check libraries. XXX this only checks Haskell libraries,
@@ -493,13 +499,18 @@ linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]
pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
- if any isNothing pkg_libfiles then return True else do
+ if any isNothing pkg_libfiles then return (RecompBecause LibraryChanged) else do
e_lib_times <- mapM (tryIO . getModificationUTCTime)
(catMaybes pkg_libfiles)
let (lib_errs,lib_times) = partitionEithers e_lib_times
if not (null lib_errs) || any (t <) lib_times
- then return True
- else checkLinkInfo logger dflags unit_env pkg_deps exe_file
+ then return (RecompBecause LibraryChanged)
+ else do
+ res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file
+ if res
+ then return (RecompBecause FlagsChanged)
+ else return UpToDate
+
findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
findHSLib platform ws dirs lib = do
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 2c371d17c9..c1f7c3769a 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -358,7 +358,7 @@ runCcPhase cc_phase pipe_env hsc_env input_fn = do
let platform = ue_platform unit_env
let hcc = cc_phase `eqPhase` HCc
- let cmdline_include_paths = includePaths dflags
+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
-- HC files have the dependent packages stamped into them
pkgs <- if hcc then getHCFilePackages input_fn else return []
@@ -379,10 +379,13 @@ runCcPhase cc_phase pipe_env hsc_env input_fn = do
-- (#16737). Doing it in this way is simpler and also enable the C
-- compiler to perform preprocessing and parsing in a single pass,
-- but it may introduce inconsistency if a different pgm_P is specified.
- let more_preprocessor_opts = concat
+ let opts = getOpts dflags opt_P
+ aug_imports = augmentImports dflags opts
+
+ more_preprocessor_opts = concat
[ ["-Xpreprocessor", i]
| not hcc
- , i <- getOpts dflags opt_P
+ , i <- aug_imports
]
let gcc_extra_viac_flags = extraGccViaCFlags dflags
@@ -935,6 +938,12 @@ llvmOptions dflags =
ArchRISCV64 -> "lp64d"
_ -> ""
+
+-- Note [Filepaths and Multiple Home Units]
+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
+ let go = map (augmentByWorkingDirectory dflags)
+ in IncludeSpecs (go incs) (go quotes) (go impl)
-- -----------------------------------------------------------------------------
-- Running CPP
@@ -944,12 +953,21 @@ llvmOptions dflags =
doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
let hscpp_opts = picPOpts dflags
- let cmdline_include_paths = includePaths dflags
+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
let unit_state = ue_units unit_env
pkg_include_dirs <- mayThrowUnitErr
(collectIncludeDirs <$> preloadUnitsInfo unit_env)
+ -- MP: This is not quite right, the headers which are supposed to be installed in
+ -- the package might not be the same as the provided include paths, but it's a close
+ -- enough approximation for things to work. A proper solution would be to have to declare which paths should
+ -- be propagated to dependent packages.
+ let home_pkg_deps =
+ [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
+ dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
+
let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
- (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
+ ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
(includePathsQuote cmdline_include_paths ++
includePathsQuoteImplicit cmdline_include_paths)
diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs
index 55026d8669..454cc8c870 100644
--- a/compiler/GHC/Driver/Pipeline/LogQueue.hs
+++ b/compiler/GHC/Driver/Pipeline/LogQueue.hs
@@ -5,13 +5,13 @@ module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)
, finishLogQueue
, writeLogQueue
, parLogAction
- , printLogs
, LogQueueQueue(..)
, initLogQueue
, allLogQueues
, newLogQueueQueue
- , dequeueLogQueueQueue
+
+ , logThread
) where
import GHC.Prelude
@@ -22,6 +22,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Logger
import qualified Data.IntMap as IM
import Control.Concurrent.STM
+import Control.Monad
-- LogQueue Abstraction
@@ -99,3 +100,24 @@ dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of
Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')
_ -> Nothing
+logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
+ -> TVar LogQueueQueue -- Queue for logs
+ -> IO (IO ())
+logThread _ _ logger stopped lqq_var = do
+ finished_var <- newEmptyMVar
+ _ <- forkIO $ print_logs *> putMVar finished_var ()
+ return (takeMVar finished_var)
+ where
+ finish = mapM (printLogs logger)
+
+ print_logs = join $ atomically $ do
+ lqq <- readTVar lqq_var
+ case dequeueLogQueueQueue lqq of
+ Just (lq, lqq') -> do
+ writeTVar lqq_var lqq'
+ return (printLogs logger lq *> print_logs)
+ Nothing -> do
+ -- No log to print, check if we are finished.
+ stopped <- readTVar stopped
+ if not stopped then retry
+ else return (finish (allLogQueues lqq))
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index d1c29bc824..b0b37a822c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -145,6 +145,7 @@ module GHC.Driver.Session (
defaultFatalMessager,
defaultFlushOut,
setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,
+ augmentByWorkingDirectory,
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
getVerbFlags,
@@ -515,6 +516,12 @@ data DynFlags = DynFlags {
homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate
homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations
+ -- Note [Filepaths and Multiple Home Units]
+ workingDirectory :: Maybe FilePath,
+ thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units
+ hiddenModules :: Set.Set ModuleName,
+ reexportedModules :: Set.Set ModuleName,
+
-- ways
targetWays_ :: Ways, -- ^ Target way flags from the command line
@@ -1136,6 +1143,11 @@ defaultDynFlags mySettings llvmConfig =
homeUnitInstanceOf_ = Nothing,
homeUnitInstantiations_ = [],
+ workingDirectory = Nothing,
+ thisPackageName = Nothing,
+ hiddenModules = Set.empty,
+ reexportedModules = Set.empty,
+
objectDir = Nothing,
dylibInstallName = Nothing,
hiDir = Nothing,
@@ -2938,6 +2950,12 @@ package_flags_deps = [
, make_ord_flag defGhcFlag "package-name" (HasArg $ \name ->
upd (setUnitId name))
, make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId)
+
+ , make_ord_flag defGhcFlag "working-dir" (hasArg setWorkingDirectory)
+ , make_ord_flag defGhcFlag "this-package-name" (hasArg setPackageName)
+ , make_ord_flag defGhcFlag "hidden-module" (HasArg addHiddenModule)
+ , make_ord_flag defGhcFlag "reexported-module" (HasArg addReexportedModule)
+
, make_ord_flag defFlag "package" (HasArg exposePackage)
, make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId)
, make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage)
@@ -4279,6 +4297,43 @@ parseUnitArg =
setUnitId :: String -> DynFlags -> DynFlags
setUnitId p d = d { homeUnitId_ = stringToUnitId p }
+setWorkingDirectory :: String -> DynFlags -> DynFlags
+setWorkingDirectory p d = d { workingDirectory = Just p }
+
+{-
+Note [Filepaths and Multiple Home Units]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is common to assume that a package is compiled in the directory where its
+cabal file resides. Thus, all paths used in the compiler are assumed to be relative
+to this directory. When there are multiple home units the compiler is often
+not operating in the standard directory and instead where the cabal.project
+file is located. In this case the `-working-dir` option can be passed which specifies
+the path from the current directory to the directory the unit assumes to be it's root,
+normally the directory which contains the cabal file.
+
+When the flag is passed, any relative paths used by the compiler are offset
+by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and
+the location of input files.
+
+-}
+
+augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath
+augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp
+augmentByWorkingDirectory _ fp = fp
+
+setPackageName :: String -> DynFlags -> DynFlags
+setPackageName p d = d { thisPackageName = Just p }
+
+addHiddenModule :: String -> DynP ()
+addHiddenModule p =
+ upd (\s -> s{ hiddenModules = Set.insert (mkModuleName p) (hiddenModules s) })
+
+addReexportedModule :: String -> DynP ()
+addReexportedModule p =
+ upd (\s -> s{ reexportedModules = Set.insert (mkModuleName p) (reexportedModules s) })
+
+
-- If we're linking a binary, then only backends that produce object
-- code are allowed (requests for other target types are ignored).
setBackend :: Backend -> DynP ()
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
index fa4f08c2ef..fbde84deda 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ b/compiler/GHC/HsToCore/Usage.hs
@@ -155,7 +155,7 @@ mkObjectUsage pit hsc_env mnwib = do
Nothing -> do
-- This should only happen for home package things but oneshot puts
-- home package ifaces in the PIT.
- let miface = lookupIfaceByModule (hsc_HPT hsc_env) pit m
+ let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m
case miface of
Nothing -> pprPanic "mkObjectUsage" (ppr m)
Just iface ->
@@ -176,7 +176,7 @@ mk_mod_usage_info :: PackageIfaceTable
mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
= mapMaybe mkUsage usage_mods
where
- hpt = hsc_HPT hsc_env
+ hpt = hsc_HUG hsc_env
dflags = hsc_dflags hsc_env
home_unit = hsc_home_unit hsc_env
diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs
index 93666ca3d5..6fecc023c5 100644
--- a/compiler/GHC/Iface/Errors.hs
+++ b/compiler/GHC/Iface/Errors.hs
@@ -17,7 +17,7 @@ import GHC.Platform.Profile
import GHC.Platform.Ways
import GHC.Utils.Panic.Plain
import GHC.Driver.Session
-import GHC.Driver.Env.Types
+import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Data.Maybe
import GHC.Prelude
@@ -213,7 +213,7 @@ cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find
= cannot_find <+> quotes (ppr mod_name)
$$ more_info
where
- mhome_unit = ue_home_unit unit_env
+ mhome_unit = ue_homeUnit unit_env
more_info
= case find_result of
NoPackage pkg
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index f1da9d7e0a..d30d39372c 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -94,7 +94,6 @@ import GHC.Types.SourceText
import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
import GHC.Types.TypeEnv
-import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet
import GHC.Types.SrcLoc
import GHC.Types.TyThing
@@ -318,12 +317,7 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
-- interface; it will call the Finder again, but the ModLocation will be
-- cached from the first search.
= do hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- let units = hsc_units hsc_env
- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- res <- liftIO $ findImportedModule fc fopts units mhome_unit mod maybe_pkg
+ res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
case res of
Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
-- TODO: Make sure this error message is good
@@ -449,15 +443,15 @@ loadInterface doc_str mod from
logger <- getLogger
withTimingSilent logger (text "loading interface") (pure ()) $ do
{ -- Read the state
- (eps,hpt) <- getEpsAndHpt
+ (eps,hug) <- getEpsAndHug
; gbl_env <- getGblEnv
; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from)
-- Check whether we have the interface already
; hsc_env <- getTopEnv
- ; let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {
+ ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
+ ; case lookupIfaceByModule hug (eps_PIT eps) mod of {
Just iface
-> return (Succeeded iface) ; -- Already loaded
-- The (src_imp == mi_boot iface) test checks that the already-loaded
@@ -497,7 +491,7 @@ loadInterface doc_str mod from
in
initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $
- dontLeakTheHPT $ do
+ dontLeakTheHUG $ do
-- Load the new ModIface into the External Package State
-- Even home-package interfaces loaded by loadInterface
@@ -515,6 +509,14 @@ loadInterface doc_str mod from
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
+ -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.
+ -- If you start loading HPT modules into the EPS then you get strange errors about
+ -- overlapping instances.
+ ; massertPpr
+ ((isOneShot (ghcMode (hsc_dflags hsc_env)))
+ || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env
+ || mod == gHC_PRIM)
+ (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))
; ignore_prags <- goptM Opt_IgnoreInterfacePragmas
; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface)
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
@@ -630,8 +632,8 @@ home-package modules however, so it's safe for the HPT to be empty.
-}
-- Note [GHC Heap Invariants]
-dontLeakTheHPT :: IfL a -> IfL a
-dontLeakTheHPT thing_inside = do
+dontLeakTheHUG :: IfL a -> IfL a
+dontLeakTheHUG thing_inside = do
env <- getTopEnv
let
inOneShot =
@@ -656,10 +658,11 @@ dontLeakTheHPT thing_inside = do
keepFor20509 hmi
| isHoleModule (mi_semantic_module (hm_iface hmi)) = True
| otherwise = False
+ pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }
!unit_env
= old_unit_env
- { ue_hpt = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_hpt old_unit_env
- else emptyHomePackageTable
+ { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env
+ else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)
}
in
hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets"
@@ -709,14 +712,8 @@ computeInterface
-> IO (MaybeErr SDoc (ModIface, FilePath))
computeInterface hsc_env doc_str hi_boot_file mod0 = do
massert (not (isHoleModule mod0))
- let name_cache = hsc_NC hsc_env
- let fc = hsc_FC hsc_env
- let mhome_unit = ue_home_unit (hsc_unit_env 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 mhome_unit dflags doc_str
+ let mhome_unit = hsc_home_unit_maybe hsc_env
+ let find_iface m = findAndReadIface hsc_env doc_str
m mod0 hi_boot_file
case getModuleInstantiation mod0 of
(imod, Just indef)
@@ -751,7 +748,7 @@ moduleFreeHolesPrecise doc_str mod
let insts = instUnitInsts (moduleUnit indef)
liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>
text "to compute precise free module holes")
- (eps, hpt) <- getEpsAndHpt
+ (eps, hpt) <- getEpsAndHug
case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of
Just r -> return (Succeeded r)
Nothing -> readAndCache imod insts
@@ -765,14 +762,7 @@ moduleFreeHolesPrecise doc_str mod
_otherwise -> Nothing
readAndCache imod insts = do
hsc_env <- getTopEnv
- let nc = hsc_NC hsc_env
- let fc = hsc_FC 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 mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- mb_iface <- liftIO $ findAndReadIface logger nc fc hooks units mhome_unit dflags
+ mb_iface <- liftIO $ findAndReadIface hsc_env
(text "moduleFreeHolesPrecise" <+> doc_str)
imod mod NotBoot
case mb_iface of
@@ -806,7 +796,7 @@ wantHiBootFile mhome_unit eps mod from
-- We never import boot modules from other packages!
| otherwise
- -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
+ -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
Just (GWIB { gwib_isBoot = is_boot }) ->
Succeeded is_boot
Nothing ->
@@ -864,13 +854,7 @@ See #8320.
-}
findAndReadIface
- :: Logger
- -> NameCache
- -> FinderCache
- -> Hooks
- -> UnitState
- -> Maybe HomeUnit
- -> DynFlags
+ :: HscEnv
-> 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
@@ -878,8 +862,18 @@ findAndReadIface
-- 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 mhome_unit dflags doc_str mod wanted_mod hi_boot_file = do
+findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
+
let profile = targetProfile dflags
+ unit_state = hsc_units hsc_env
+ fc = hsc_FC hsc_env
+ name_cache = hsc_NC hsc_env
+ mhome_unit = hsc_home_unit_maybe hsc_env
+ dflags = hsc_dflags hsc_env
+ logger = hsc_logger hsc_env
+ hooks = hsc_hooks hsc_env
+ other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
+
trace_if logger (sep [hsep [text "Reading",
if hi_boot_file == IsBoot
@@ -901,7 +895,7 @@ findAndReadIface logger name_cache fc hooks unit_state mhome_unit dflags doc_str
else do
let fopts = initFinderOpts dflags
-- Look for the file
- mb_found <- liftIO (findExactModule fc fopts unit_state mhome_unit mod)
+ mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
case mb_found of
InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
-- See Note [Home module load error]
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 6b184787fa..fc12701b61 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -53,8 +53,6 @@ import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
import GHC.Types.Fixity.Env
-
-import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Finder
import GHC.Unit.State
@@ -78,6 +76,7 @@ import qualified Data.Semigroup
import GHC.List (uncons)
import Data.Ord
import Data.Containers.ListUtils
+import Data.Bifunctor
{-
-----------------------------------------------
@@ -121,6 +120,11 @@ data RecompileRequired
-- to force recompilation; the String says what (one-line summary)
deriving (Eq)
+instance Outputable RecompileRequired where
+ ppr UpToDate = text "UpToDate"
+ ppr MustCompile = text "MustCompile"
+ ppr (RecompBecause r) = text "RecompBecause" <+> ppr r
+
instance Semigroup RecompileRequired where
UpToDate <> r = r
mc <> _ = mc
@@ -141,8 +145,8 @@ data RecompReason
| HieOutdated
| SigsMergeChanged
| ModuleChanged ModuleName
- | ModuleRemoved ModuleName
- | ModuleAdded ModuleName
+ | ModuleRemoved (UnitId, ModuleName)
+ | ModuleAdded (UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
@@ -155,6 +159,8 @@ data RecompReason
| MissingDynObjectFile
| MissingDynHiFile
| MismatchedDynHiFile
+ | ObjectsChanged
+ | LibraryChanged
deriving (Eq)
instance Outputable RecompReason where
@@ -173,8 +179,8 @@ instance Outputable RecompReason where
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
ModuleChangedIface m -> ppr m <+> text "changed (interface)"
- ModuleRemoved m -> ppr m <+> text "removed"
- ModuleAdded m -> ppr m <+> text "added"
+ ModuleRemoved (_uid, m) -> ppr m <+> text "removed"
+ ModuleAdded (_uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
@@ -185,6 +191,8 @@ instance Outputable RecompReason where
MissingDynObjectFile -> text "Missing dynamic object file"
MissingDynHiFile -> text "Missing dynamic interface file"
MismatchedDynHiFile -> text "Mismatched dynamic interface file"
+ ObjectsChanged -> text "Objects changed"
+ LibraryChanged -> text "Library changed"
recompileRequired :: RecompileRequired -> Bool
recompileRequired UpToDate = False
@@ -526,7 +534,7 @@ checkMergedSignatures hsc_env mod_summary iface = do
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
= do
- res_normal <- classify_import (findImportedModule fc fopts units mhome_unit) (ms_textual_imps summary ++ ms_srcimps summary)
+ res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
Left recomp -> return recomp
@@ -539,6 +547,11 @@ checkDependencies hsc_env summary iface
return (res1 `mappend` res2)
where
+ classify_import :: (ModuleName -> t -> IO FindResult)
+ -> [(t, GenLocated l ModuleName)]
+ -> IfG
+ [Either
+ RecompileRequired (Either (UnitId, ModuleName) (String, UnitId))]
classify_import find_import imports =
liftIO $ traverse (\(mb_pkg, L _ mod) ->
let reason = ModuleChanged mod
@@ -548,9 +561,10 @@ checkDependencies hsc_env summary iface
fopts = initFinderOpts dflags
logger = hsc_logger hsc_env
fc = hsc_FC hsc_env
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
+ mhome_unit = hsc_home_unit_maybe hsc_env
+ all_home_units = hsc_all_home_unit_ids hsc_env
units = hsc_units hsc_env
- prev_dep_mods = map gwib_mod $ Set.toAscList $ dep_direct_mods (mi_deps iface)
+ prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))
(dep_plugin_pkgs (mi_deps iface)))
bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface)))
@@ -560,23 +574,26 @@ checkDependencies hsc_env summary iface
-- GHC.Prim is very special and doesn't appear in ms_textual_imps but
-- ghc-prim will appear in the package dependencies still. In order to not confuse
-- the recompilation logic we need to not forget we imported GHC.Prim.
- fake_ghc_prim_import = if notHomeUnitId mhome_unit primUnitId
- then Right ("GHC.Prim", primUnitId)
- else Left (mkModuleName "GHC.Prim")
+ fake_ghc_prim_import = case mhome_unit of
+ Just home_unit
+ | homeUnitId home_unit == primUnitId
+ -> Left (primUnitId, mkModuleName "GHC.Prim")
+ _ -> Right ("GHC.Prim", primUnitId)
classify _ (Found _ mod)
- | Just home_unit <- mhome_unit
- , isHomeUnit home_unit (moduleUnit mod) = Right (Left (moduleName mod))
+ | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))
| otherwise = Right (Right (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod))
classify reason _ = Left (RecompBecause reason)
+ check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
check_mods [] [] = return UpToDate
check_mods [] (old:_) = do
-- This case can happen when a module is change from HPT to package import
trace_hi_diffs logger $
- text "module no longer " <> quotes (ppr old) <>
+ text "module no longer" <+> quotes (ppr old) <+>
text "in dependencies"
+
return (RecompBecause (ModuleRemoved old))
check_mods (new:news) olds
| Just (old, olds') <- uncons olds
@@ -1255,21 +1272,14 @@ addFingerprints hsc_env iface0
-- to recompile C and everything else.
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
- eps <- hscEPS hsc_env
let
- hpt = hsc_HPT hsc_env
dflags = hsc_dflags hsc_env
- pit = eps_PIT eps
ctx = initSDocContext dflags defaultUserStyle
- get_orph_hash mod =
- case lookupIfaceByModule hpt pit mod of
- Just iface -> return (mi_orphan_hash (mi_final_exts iface))
- Nothing -> do -- similar to 'mkHashFun'
- iface <- initIfaceLoad hsc_env . withException ctx
+ get_orph_hash mod = do
+ iface <- initIfaceLoad hsc_env . withException ctx
$ loadInterface (text "getOrphanHashes") mod ImportBySystem
- return (mi_orphan_hash (mi_final_exts iface))
+ return (mi_orphan_hash (mi_final_exts iface))
- --
mapM get_orph_hash mods
@@ -1546,7 +1556,7 @@ mkHashFun hsc_env eps name
where
home_unit = hsc_home_unit hsc_env
dflags = hsc_dflags hsc_env
- hpt = hsc_HPT hsc_env
+ hpt = hsc_HUG hsc_env
pit = eps_PIT eps
ctx = initSDocContext dflags defaultUserStyle
occ = nameOccName name
diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs
index 15e8623404..dc358d1c2d 100644
--- a/compiler/GHC/Iface/Recomp/Flags.hs
+++ b/compiler/GHC/Iface/Recomp/Flags.hs
@@ -37,7 +37,7 @@ fingerprintDynFlags :: HscEnv -> Module
fingerprintDynFlags hsc_env this_mod nameio =
let dflags@DynFlags{..} = hsc_dflags hsc_env
- mainis = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing
+ mainis = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing
-- see #5878
-- pkgopts = (homeUnit home_unit, sort $ packageFlags dflags)
safeHs = setSafeMode safeHaskell
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 782b572cf8..4b3316f632 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -539,8 +539,8 @@ tcHiBootIface hsc_src mod
-- (it's been replaced by the mother module) so we can't check it.
-- And that's fine, because if M's ModInfo is in the HPT, then
-- it's been compiled once, and we don't need to check the boot iface
- then do { hpt <- getHpt
- ; case lookupHpt hpt (moduleName mod) of
+ then do { (_, hug) <- getEpsAndHug
+ ; case lookupHugByModule mod hug of
Just info | mi_boot (hm_iface info) == IsBoot
-> mkSelfBootInfo (hm_iface info) (hm_details info)
_ -> return NoSelfBoot }
@@ -551,14 +551,7 @@ 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
- ; let nc = hsc_NC hsc_env
- ; let fc = hsc_FC hsc_env
- ; let mhome_unit = ue_home_unit (hsc_unit_env 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 mhome_unit dflags
+ ; read_result <- liftIO $ findAndReadIface hsc_env
need (fst (getModuleInstantiation mod)) mod
IsBoot -- Hi-boot file
@@ -575,7 +568,7 @@ tcHiBootIface hsc_src mod
-- a SOURCE import) or that our hi-boot file has mysteriously
-- disappeared.
do { eps <- getEps
- ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
+ ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
-- The typical case
Nothing -> return NoSelfBoot
-- error cases
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
index 80e303b046..6fc324e27a 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ b/compiler/GHC/Linker/Loader.hs
@@ -54,7 +54,6 @@ import GHC.Tc.Utils.Monad
import GHC.Runtime.Interpreter
import GHCi.RemoteTypes
-import GHC.Iface.Load
import GHC.ByteCode.Linker
import GHC.ByteCode.Asm
@@ -72,7 +71,6 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (isWindowsHost, isDarwinHost)
-import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.TmpFs
@@ -82,7 +80,6 @@ import GHC.Unit.Finder
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
-import GHC.Unit.Home
import GHC.Unit.Home.ModInfo
import GHC.Unit.State as Packages
@@ -119,6 +116,12 @@ import GHC.Utils.Exception
import qualified Data.Map as M
import Data.Either (partitionEithers)
+import GHC.Unit.Module.Graph
+import GHC.Types.SourceFile
+import GHC.Utils.Misc
+import GHC.Iface.Load
+import GHC.Unit.Home
+
uninitialised :: a
uninitialised = panic "Loader not initialised"
@@ -210,7 +213,6 @@ loadDependencies
-> IO (LoaderState, SuccessFlag)
loadDependencies interp hsc_env pls span needed_mods = do
-- initLoaderState (hsc_dflags hsc_env) dl
- let hpt = hsc_HPT hsc_env
let dflags = hsc_dflags hsc_env
-- The interpreter and dynamic linker can only handle object code built
-- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
@@ -219,11 +221,11 @@ loadDependencies interp hsc_env pls span needed_mods = do
maybe_normal_osuf <- checkNonStdWay dflags interp (fst span)
-- Find what packages and linkables are required
- (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env hpt pls
+ (lnks, all_lnks, pkgs) <- getLinkDeps hsc_env pls
maybe_normal_osuf (fst span) needed_mods
let pls1 =
- case (snd span) of
+ case snd span of
Just mn -> pls { module_deps = M.insertWith (++) mn all_lnks (module_deps pls) }
Nothing -> pls
@@ -310,8 +312,9 @@ reallyInitLoaderState interp hsc_env = do
-- (a) initialise the C dynamic linker
initObjLinker interp
+
-- (b) Load packages from the command-line (Note [preload packages])
- pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0
+ pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)
-- steps (c), (d) and (e)
loadCmdLineLibs' interp hsc_env pls
@@ -323,13 +326,33 @@ loadCmdLineLibs interp hsc_env = do
modifyLoaderState_ interp $ \pls ->
loadCmdLineLibs' interp hsc_env pls
-loadCmdLineLibs'
+
+loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState
+loadCmdLineLibs' interp hsc_env pls = snd <$>
+ foldM
+ (\(done', pls') cur_uid -> load done' cur_uid pls')
+ (Set.empty, pls)
+ (hsc_all_home_unit_ids hsc_env)
+
+ where
+ load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState)
+ load done uid pls | uid `Set.member` done = return (done, pls)
+ load done uid pls = do
+ let hsc' = hscSetActiveUnitId uid hsc_env
+ -- Load potential dependencies first
+ (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
+ (homeUnitDepends (hsc_units hsc'))
+ pls'' <- loadCmdLineLibs'' interp hsc' pls'
+ return $ (Set.insert uid done', pls'')
+
+loadCmdLineLibs''
:: Interp
-> HscEnv
-> LoaderState
-> IO LoaderState
-loadCmdLineLibs' interp hsc_env pls =
+loadCmdLineLibs'' interp hsc_env pls =
do
+
let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
, libraryPaths = lib_paths_base})
= hsc_dflags hsc_env
@@ -661,7 +684,7 @@ failNonStd dflags srcspan = dieWith dflags srcspan $
Prof -> "with -prof"
Dyn -> "with -dynamic"
-getLinkDeps :: HscEnv -> HomePackageTable
+getLinkDeps :: HscEnv
-> LoaderState
-> Maybe FilePath -- replace object suffixes?
-> SrcSpan -- for error messages
@@ -669,13 +692,21 @@ getLinkDeps :: HscEnv -> HomePackageTable
-> IO ([Linkable], [Linkable], [UnitId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
-getLinkDeps hsc_env hpt pls replace_osuf span mods
+getLinkDeps hsc_env pls replace_osuf span mods
-- Find all the packages and linkables that a set of modules depends on
= do {
-- 1. Find the dependent home-pkg-modules/packages from each iface
-- (omitting modules from the interactive package, which is already linked)
- ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)
- emptyUniqDSet emptyUniqDSet;
+ ; (mods_s, pkgs_s) <-
+ -- Why two code paths here? There is a significant amount of repeated work
+ -- performed calculating transitive dependencies
+ -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
+ if isOneShot (ghcMode dflags)
+ then follow_deps (filterOut isInteractiveModule mods)
+ emptyUniqDSet emptyUniqDSet;
+ else do
+ (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
+ return (catMaybes mmods, Set.toList (Set.unions (init_pkg_set : pkgs)))
; let
-- 2. Exclude ones already linked
@@ -683,11 +714,11 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
(mods_needed, mods_got) = partitionEithers (map split_mods mods_s)
pkgs_needed = pkgs_s `minusList` pkgs_loaded pls
- split_mods mod_name =
- let is_linked = find ((== mod_name) . (moduleName . linkableModule)) (objs_loaded pls ++ bcos_loaded pls)
+ split_mods mod =
+ let is_linked = find ((== mod) . (linkableModule)) (objs_loaded pls ++ bcos_loaded pls)
in case is_linked of
Just linkable -> Right linkable
- Nothing -> Left mod_name
+ Nothing -> Left mod
-- 3. For each dependent module, find its linkable
-- This will either be in the HPT or (in the case of one-shot
@@ -698,16 +729,62 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
; return (lnks_needed, mods_got ++ lnks_needed, pkgs_needed) }
where
dflags = hsc_dflags hsc_env
+ mod_graph = hsc_mod_graph hsc_env
- -- The ModIface contains the transitive closure of the module dependencies
- -- within the current package, *except* for boot modules: if we encounter
- -- a boot module, we have to find its real interface and discover the
- -- dependencies of that. Hence we need to traverse the dependency
- -- tree recursively. See bug #936, testcase ghci/prog007.
+ -- This code is used in `--make` mode to calculate the home package and unit dependencies
+ -- for a set of modules.
+ --
+ -- It is significantly more efficient to use the shared transitive dependency
+ -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
+
+ -- It is also a matter of correctness to use the module graph so that dependencies between home units
+ -- is resolved correctly.
+ make_deps_loop :: (Set.Set UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (Set.Set UnitId, Set.Set NodeKey)
+ make_deps_loop found [] = found
+ make_deps_loop found@(found_units, found_mods) (nk:nexts)
+ | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
+ | otherwise =
+ case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
+ Just trans_deps ->
+ let deps = Set.insert (NodeKey_Module nk) trans_deps
+ -- See #936 and the ghci.prog007 test for why we have to continue traversing through
+ -- boot modules.
+ todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
+ in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
+ Nothing ->
+ let (ModNodeKeyWithUid _ uid) = nk
+ in make_deps_loop (uid `Set.insert` found_units, found_mods) nexts
+
+ mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
+ (init_pkg_set, all_deps) = make_deps_loop (Set.empty, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)
+
+ all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
+
+ get_mod_info (ModNodeKeyWithUid gwib uid) =
+ case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of
+ Just hmi ->
+ let iface = (hm_iface hmi)
+ mmod = case mi_hsc_src iface of
+ HsBootFile -> link_boot_mod_error (mi_module iface)
+ _ -> return $ Just (mi_module iface)
+
+ in (dep_direct_pkgs (mi_deps iface),) <$> mmod
+ Nothing ->
+ let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
+ in throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+
+
+ -- This code is used in one-shot mode to traverse downwards through the HPT
+ -- to find all link dependencies.
+ -- The ModIface contains the transitive closure of the module dependencies
+ -- within the current package, *except* for boot modules: if we encounter
+ -- a boot module, we have to find its real interface and discover the
+ -- dependencies of that. Hence we need to traverse the dependency
+ -- tree recursively. See bug #936, testcase ghci/prog007.
follow_deps :: [Module] -- modules to follow
- -> UniqDSet ModuleName -- accum. module dependencies
+ -> UniqDSet Module -- accum. module dependencies
-> UniqDSet UnitId -- accum. package dependencies
- -> IO ([ModuleName], [UnitId]) -- result
+ -> IO ([Module], [UnitId]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
@@ -727,23 +804,28 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
pkg_deps = dep_direct_pkgs deps
(boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
\case
- GWIB m IsBoot -> Left m
- GWIB m NotBoot -> Right m
-
- mod_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) (boot_deps ++ mod_deps)
- acc_mods' = addListToUniqDSet acc_mods (moduleName mod : mod_deps)
+ (_, GWIB m IsBoot) -> Left m
+ (_, GWIB m NotBoot) -> Right m
+
+ mod_deps' = case hsc_home_unit_maybe hsc_env of
+ Nothing -> []
+ Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
+ acc_mods' = case hsc_home_unit_maybe hsc_env of
+ Nothing -> acc_mods
+ Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
- --
- case ue_home_unit (hsc_unit_env hsc_env) of
- Just home_unit
- | isHomeUnit home_unit pkg
- -> follow_deps (map (mkHomeModule home_unit) mod_deps' ++ mods) acc_mods' acc_pkgs'
- _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
+
+ case hsc_home_unit_maybe hsc_env of
+ Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)
+ acc_mods' acc_pkgs'
+ _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
where
- msg = text "need to link module" <+> ppr mod <+>
+ msg = text "need to link module" <+> ppr mod <+>
text "due to use of Template Haskell"
+
+ link_boot_mod_error :: Module -> IO a
link_boot_mod_error mod =
throwGhcExceptionIO (ProgramError (showSDoc dflags (
text "module" <+> ppr mod <+>
@@ -759,22 +841,23 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
-- This one is a build-system bug
- get_linkable osuf mod_name -- A home-package module
- | Just mod_info <- lookupHpt hpt mod_name
+ get_linkable osuf mod -- A home-package module
+ | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)
= adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
- case ue_home_unit (hsc_unit_env hsc_env) of
- Nothing -> no_obj mod_name
+ case hsc_home_unit_maybe hsc_env of
+ Nothing -> no_obj mod
Just home_unit -> do
+
let fc = hsc_FC hsc_env
let dflags = hsc_dflags hsc_env
let fopts = initFinderOpts dflags
- mb_stuff <- findHomeModule fc fopts home_unit mod_name
+ mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
case mb_stuff of
Found loc mod -> found loc mod
- _ -> no_obj mod_name
+ _ -> no_obj (moduleName mod)
where
found loc mod = do {
-- ...and then find the linkable for it
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
index 108dbec525..5d63d59461 100644
--- a/compiler/GHC/Linker/Static.hs
+++ b/compiler/GHC/Linker/Static.hs
@@ -2,7 +2,6 @@ module GHC.Linker.Static
( linkBinary
, linkBinary'
, linkStaticLib
- , exeFileName
)
where
@@ -29,6 +28,7 @@ import GHC.Linker.Unit
import GHC.Linker.Dynamic
import GHC.Linker.ExtraObj
import GHC.Linker.Windows
+import GHC.Linker.Static.Utils
import GHC.Driver.Session
@@ -306,30 +306,3 @@ linkStaticLib logger dflags unit_env o_files dep_units = do
-- run ranlib over the archive. write*Ar does *not* create the symbol index.
runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]
-
-
-
--- | Compute the output file name of a program.
---
--- StaticLink boolean is used to indicate if the program is actually a static library
--- (e.g., on iOS).
---
--- Use the provided filename (if any), otherwise use "main.exe" (Windows),
--- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the
--- extension if it is missing.
-exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath
-exeFileName platform staticLink output_fn
- | Just s <- output_fn =
- case platformOS platform of
- OSMinGW32 -> s <?.> "exe"
- _ -> if staticLink
- then s <?.> "a"
- else s
- | otherwise =
- if platformOS platform == OSMinGW32
- then "main.exe"
- else if staticLink
- then "liba.a"
- else "a.out"
- where s <?.> ext | null (takeExtension s) = s <.> ext
- | otherwise = s
diff --git a/compiler/GHC/Linker/Static/Utils.hs b/compiler/GHC/Linker/Static/Utils.hs
new file mode 100644
index 0000000000..6439d197d8
--- /dev/null
+++ b/compiler/GHC/Linker/Static/Utils.hs
@@ -0,0 +1,31 @@
+module GHC.Linker.Static.Utils where
+
+import GHC.Prelude
+import GHC.Platform
+import System.FilePath
+
+-- | Compute the output file name of a program.
+--
+-- StaticLink boolean is used to indicate if the program is actually a static library
+-- (e.g., on iOS).
+--
+-- Use the provided filename (if any), otherwise use "main.exe" (Windows),
+-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the
+-- extension if it is missing.
+exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath
+exeFileName platform staticLink output_fn
+ | Just s <- output_fn =
+ case platformOS platform of
+ OSMinGW32 -> s <?.> "exe"
+ _ -> if staticLink
+ then s <?.> "a"
+ else s
+ | otherwise =
+ if platformOS platform == OSMinGW32
+ then "main.exe"
+ else if staticLink
+ then "liba.a"
+ else "a.out"
+ where s <?.> ext | null (takeExtension s) = s <.> ext
+ | otherwise = s
+
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 34141ab9f4..8108a9e873 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -73,7 +73,6 @@ import GHC.Types.Basic ( TopLevelFlag(..) )
import GHC.Types.SourceText
import GHC.Types.Id
import GHC.Types.HpcInfo
-import GHC.Types.Unique.FM
import GHC.Types.Error
import GHC.Types.PkgQual
@@ -217,7 +216,7 @@ rnImports imports = do
clobberSourceImports imp_avails =
imp_avails { imp_boot_mods = imp_boot_mods' }
where
- imp_boot_mods' = mergeUFM combJ id (const mempty)
+ imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv)
(imp_boot_mods imp_avails)
(imp_direct_dep_mods imp_avails)
@@ -327,6 +326,7 @@ rnImportDecl this_mod
let imp_mod_name = unLoc loc_imp_mod_name
doc = ppr imp_mod_name <+> import_reason
+ hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
@@ -348,7 +348,7 @@ rnImportDecl this_mod
-- or the name of this_mod's package. Yurgh!
-- c.f. GHC.findModule, and #9997
NoPkgQual -> True
- ThisPkg _ -> True
+ ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env)
OtherPkg _ -> False))
(addErr $ TcRnUnknownMessage $ mkPlainError noHints $
(text "A module cannot import itself:" <+> ppr imp_mod_name))
@@ -413,6 +413,7 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
let home_unit = hsc_home_unit hsc_env
+ other_home_units = hsc_all_home_unit_ids hsc_env
imv = ImportedModsVal
{ imv_name = qual_mod_name
, imv_span = locA loc
@@ -421,7 +422,7 @@ rnImportDecl this_mod
, imv_all_exports = potential_gres
, imv_qualified = qual_only
}
- imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)
+ imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)
-- Complain if we import a deprecated module
case mi_warns iface of
@@ -463,8 +464,11 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
renamePkgQual unit_env mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
- | Just uid <- homeUnitId <$> ue_home_unit unit_env
- , pkg_fs == fsLit "this" || pkg_fs == unitFS uid
+ | Just uid <- homeUnitId <$> ue_homeUnit unit_env
+ , pkg_fs == fsLit "this"
+ -> ThisPkg uid
+
+ | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
| Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
@@ -474,16 +478,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
-> OtherPkg (UnitId pkg_fs)
-- not really correct as pkg_fs is unlikely to be a valid unit-id but
-- we will report the failure later...
+ where
+ home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps
+
+ units = ue_units unit_env
+
+ hpt_deps :: [UnitId]
+ hpt_deps = homeUnitDepends units
+
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
calculateAvails :: HomeUnit
+ -> S.Set UnitId
-> ModIface
-> IsSafeImport
-> IsBootInterface
-> ImportedBy
-> ImportAvails
-calculateAvails home_unit iface mod_safe' want_boot imported_by =
+calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =
let imp_mod = mi_module iface
imp_sem_mod= mi_semantic_module iface
orph_iface = mi_orphan (mi_final_exts iface)
@@ -545,24 +558,24 @@ calculateAvails home_unit iface mod_safe' want_boot imported_by =
| isHomeUnit home_unit pkg = ptrust
| otherwise = False
- dependent_pkgs = if isHomeUnit home_unit pkg
+ dependent_pkgs = if toUnitId pkg `S.member` other_home_units
then S.empty
else S.singleton ipkg
- direct_mods = mkModDeps $ if isHomeUnit home_unit pkg
- then S.singleton (GWIB (moduleName imp_mod) want_boot)
+ direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units
+ then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))
else S.empty
dep_boot_mods_map = mkModDeps (dep_boot_mods deps)
boot_mods
-- If we are looking for a boot module, it must be HPT
- | IsBoot <- want_boot = addToUFM dep_boot_mods_map (moduleName imp_mod) (GWIB (moduleName imp_mod) IsBoot)
+ | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)
-- Now we are importing A properly, so don't go looking for
-- A.hs-boot
| isHomeUnit home_unit pkg = dep_boot_mods_map
-- There's no boot files to find in external imports
- | otherwise = emptyUFM
+ | otherwise = emptyInstalledModuleEnv
sig_mods =
if is_sig
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index e934692334..3d4e92d438 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -134,6 +134,7 @@ import GHC.Tc.Utils.Instantiate (instDFunType)
import GHC.Tc.Solver (simplifyWantedsTcM)
import GHC.Tc.Utils.Monad
import GHC.Core.Class (classTyCon)
+import GHC.Unit.Env
-- -----------------------------------------------------------------------------
-- running a statement interactively
@@ -150,7 +151,7 @@ getHistoryModule = breakInfo_module . historyBreakInfo
getHistorySpan :: HscEnv -> History -> SrcSpan
getHistorySpan hsc_env History{..} =
let BreakInfo{..} = historyBreakInfo in
- case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
+ case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of
Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
_ -> panic "getHistorySpan"
@@ -161,7 +162,7 @@ getHistorySpan hsc_env History{..} =
findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
findEnclosingDecls hsc_env (BreakInfo modl ix) =
let hmi = expectJust "findEnclosingDecls" $
- lookupHpt (hsc_HPT hsc_env) (moduleName modl)
+ lookupHugByModule modl (hsc_HUG hsc_env)
mb = getModBreaks hmi
in modBreaks_decls mb ! ix
@@ -1248,8 +1249,7 @@ showModule mod_summary =
withSession $ \hsc_env -> do
interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
let dflags = hsc_dflags hsc_env
- -- extendModSummaryNoDeps because the message doesn't look at the deps
- return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary)))
+ return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))
moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index e93e6969bc..3803bc39fe 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -270,7 +270,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
let fc = hsc_FC hsc_env
let unit_env = hsc_unit_env hsc_env
let unit_state = ue_units unit_env
- let mhome_unit = ue_home_unit unit_env
+ let mhome_unit = hsc_home_unit_maybe hsc_env
-- First find the unit the module resides in by searching exposed units and home modules
found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
case found_module of
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index ca4e7de21e..73b3835282 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -49,10 +49,21 @@ runUnlit logger dflags args = traceToolCommand logger "unlit" $ do
runSomething logger "Literate pre-processor" prog
(map Option opts ++ args)
+-- | Prepend the working directory to the search path.
+-- Note [Filepaths and Multiple Home Units]
+augmentImports :: DynFlags -> [FilePath] -> [FilePath]
+augmentImports dflags fps | Nothing <- workingDirectory dflags = fps
+augmentImports _ [] = []
+augmentImports _ [x] = [x]
+augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps
+augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)
+
runCpp :: Logger -> DynFlags -> [Option] -> IO ()
runCpp logger dflags args = traceToolCommand logger "cpp" $ do
+ let opts = getOpts dflags opt_P
+ modified_imports = augmentImports dflags opts
let (p,args0) = pgm_P dflags
- args1 = map Option (getOpts dflags opt_P)
+ args1 = map Option modified_imports
args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
mb_env <- getGccEnv args2
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index acf5a9da3f..40a3732a0e 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -174,7 +174,7 @@ rnExports explicit_mod exports
, tcg_rdr_env = rdr_env
, tcg_imports = imports
, tcg_src = hsc_src } = tcg_env
- default_main | mainModIs hsc_env == this_mod
+ default_main | mainModIs (hsc_HUE hsc_env) == this_mod
, Just main_fun <- mainFunIs dflags
= mkUnqual varName (fsLit main_fun)
| otherwise
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index d1e8ce2abe..a38d6d436f 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -1209,6 +1209,10 @@ instance TH.Quasi TcM where
-- we'll only fail higher up.
qRecover recover main = tryTcDiscardingErrs recover main
+ qGetPackageRoot = do
+ dflags <- getDynFlags
+ return $ fromMaybe "." (workingDirectory dflags)
+
qAddDependentFile fp = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
@@ -1627,6 +1631,7 @@ handleTHMessage msg = case msg of
wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
ReifyModule m -> wrapTHResult $ TH.qReifyModule m
ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
+ GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
AddModFinalizer r -> do
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index 01b5433cdc..6ce522385b 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -61,6 +61,7 @@ import qualified Data.List.NonEmpty as NE
import Data.Function ( on )
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Unit.Env (unitEnv_hpts)
{- Note [The type family instance consistency story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -293,14 +294,14 @@ This is basically the idea from #13092, comment:14.
-- See Note [The type family instance consistency story].
checkFamInstConsistency :: [Module] -> TcM ()
checkFamInstConsistency directlyImpMods
- = do { (eps, hpt) <- getEpsAndHpt
+ = do { (eps, hug) <- getEpsAndHug
; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
; let { -- Fetch the iface of a given module. Must succeed as
-- all directly imported modules must already have been loaded.
modIface mod =
- case lookupIfaceByModule hpt (eps_PIT eps) mod of
+ case lookupIfaceByModule hug (eps_PIT eps) mod of
Nothing -> panicDoc "FamInst.checkFamInstConsistency"
- (ppr mod $$ pprHPT hpt)
+ (ppr mod $$ ppr hug)
Just iface -> iface
-- Which family instance modules were checked for consistency
@@ -318,7 +319,8 @@ checkFamInstConsistency directlyImpMods
; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
. md_fam_insts . hm_details
; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
- | hmi <- eltsHpt hpt]
+ | hpt <- unitEnv_hpts hug
+ , hmi <- eltsHpt hpt ]
}
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 68bfba4448..66f7406745 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -375,18 +375,18 @@ tcRnImports hsc_env import_decls
= do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
; this_mod <- getModule
- ; let { dep_mods :: ModuleNameEnv ModuleNameWithIsBoot
- ; dep_mods = imp_direct_dep_mods imports
-
- -- We want instance declarations from all home-package
+ ; gbl_env <- getGblEnv
+ ; let { -- We want instance declarations from all home-package
-- modules below this one, including boot modules, except
-- ourselves. The 'except ourselves' is so that we don't
-- get the instances from this module's hs-boot file. This
-- filtering also ensures that we don't see instances from
-- modules batch (@--make@) compiled before this one, but
-- which are not below this one.
- ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod)
- (S.fromList (nonDetEltsUFM dep_mods))
+ ; (home_insts, home_fam_insts) =
+
+ hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))
+
} ;
-- Record boot-file info in the EPS, so that it's
@@ -1790,7 +1790,7 @@ checkMainType :: TcGblEnv -> TcRn WantedConstraints
-- See Note [Dealing with main]
checkMainType tcg_env
= do { hsc_env <- getTopEnv
- ; if tcg_mod tcg_env /= mainModIs hsc_env
+ ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env)
then return emptyWC else
do { rdr_env <- getGlobalRdrEnv
@@ -1822,7 +1822,7 @@ checkMain explicit_mod_hdr export_ies
; tcg_env <- getGblEnv
; let dflags = hsc_dflags hsc_env
- main_mod = mainModIs hsc_env
+ main_mod = mainModIs (hsc_HUE hsc_env)
main_occ = getMainOcc dflags
exported_mains :: [Name]
@@ -2953,7 +2953,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, ppr_fam_insts fam_insts
, ppr_rules rules
, text "Dependent modules:" <+>
- pprUFM (imp_direct_dep_mods imports) (ppr . sort)
+ (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports)
, text "Dependent packages:" <+>
ppr (S.toList $ imp_dep_direct_pkgs imports)]
-- The use of sort is just to reduce unnecessary
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
index 5a4f9a8deb..2edee72207 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ b/compiler/GHC/Tc/Plugin.hs
@@ -73,7 +73,6 @@ import GHC.Tc.Types.Evidence ( CoercionHole, EvTerm(..)
, EvExpr, EvBindsVar, EvBind, mkGivenEvBind )
import GHC.Types.Var ( EvVar )
-import GHC.Unit.Env
import GHC.Unit.Module ( ModuleName, Module )
import GHC.Types.Name ( OccName, Name )
import GHC.Types.TyThing ( TyThing )
@@ -81,8 +80,7 @@ import GHC.Core.Reduction ( Reduction )
import GHC.Core.TyCon ( TyCon )
import GHC.Core.DataCon ( DataCon )
import GHC.Core.Class ( Class )
-import GHC.Driver.Config.Finder ( initFinderOpts )
-import GHC.Driver.Env ( HscEnv(..), hsc_units )
+import GHC.Driver.Env ( HscEnv(..) )
import GHC.Utils.Outputable ( SDoc )
import GHC.Core.Type ( Kind, Type, PredType )
import GHC.Types.Id ( Id )
@@ -103,12 +101,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult
findImportedModule mod_name mb_pkg = do
hsc_env <- getTopEnv
- let fc = hsc_FC hsc_env
- let mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- let units = hsc_units hsc_env
- let dflags = hsc_dflags hsc_env
- let fopts = initFinderOpts dflags
- tcPluginIO $ Finder.findImportedModule fc fopts units mhome_unit mod_name mb_pkg
+ tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
lookupOrig :: Module -> OccName -> TcPluginM Name
lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 393b9678d2..df9384fea2 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -1374,16 +1374,16 @@ peCategory NoDataKindsDC = "data constructor"
-}
-mkModDeps :: Set ModuleNameWithIsBoot
- -> ModuleNameEnv ModuleNameWithIsBoot
-mkModDeps deps = S.foldl' add emptyUFM deps
+mkModDeps :: Set (UnitId, ModuleNameWithIsBoot)
+ -> InstalledModuleEnv ModuleNameWithIsBoot
+mkModDeps deps = S.foldl' add emptyInstalledModuleEnv deps
where
- add env elt = addToUFM env (gwib_mod elt) elt
+ add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt
-plusModDeps :: ModuleNameEnv ModuleNameWithIsBoot
- -> ModuleNameEnv ModuleNameWithIsBoot
- -> ModuleNameEnv ModuleNameWithIsBoot
-plusModDeps = plusUFM_C plus_mod_dep
+plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot
+ -> InstalledModuleEnv ModuleNameWithIsBoot
+ -> InstalledModuleEnv ModuleNameWithIsBoot
+plusModDeps = plusInstalledModuleEnv plus_mod_dep
where
plus_mod_dep r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })
r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})
@@ -1396,12 +1396,12 @@ plusModDeps = plusUFM_C plus_mod_dep
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
- imp_direct_dep_mods = emptyUFM,
+ imp_direct_dep_mods = emptyInstalledModuleEnv,
imp_dep_direct_pkgs = S.empty,
imp_sig_mods = [],
imp_trust_pkgs = S.empty,
imp_trust_own_pkg = False,
- imp_boot_mods = emptyUFM,
+ imp_boot_mods = emptyInstalledModuleEnv,
imp_orphs = [],
imp_finsts = [] }
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index cf4925d2cb..659fc8a474 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -18,7 +18,6 @@ module GHC.Tc.Utils.Backpack (
import GHC.Prelude
-import GHC.Driver.Config.Finder
import GHC.Driver.Env
import GHC.Driver.Ppr
import GHC.Driver.Session
@@ -41,7 +40,6 @@ import GHC.Types.Name.Shape
import GHC.Types.PkgQual
import GHC.Unit
-import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.Module.Warnings
import GHC.Unit.Module.ModIface
@@ -307,17 +305,13 @@ implicitRequirements :: HscEnv
implicitRequirements hsc_env normal_imports
= fmap concat $
forM normal_imports $ \(mb_pkg, L _ imp) -> do
- found <- findImportedModule fc fopts units mhome_unit imp mb_pkg
+ found <- findImportedModule hsc_env imp mb_pkg
case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
return (uniqDSetToList (moduleFreeHoles mod))
_ -> return []
where
- fc = hsc_FC hsc_env
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- units = hsc_units hsc_env
- dflags = hsc_dflags hsc_env
- fopts = initFinderOpts dflags
+ mhome_unit = hsc_home_unit_maybe 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,15 +323,11 @@ implicitRequirementsShallow
-> IO ([ModuleName], [InstantiatedUnit])
implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
where
- fc = hsc_FC hsc_env
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
- units = hsc_units hsc_env
- dflags = hsc_dflags hsc_env
- fopts = initFinderOpts dflags
+ mhome_unit = hsc_home_unit_maybe hsc_env
go acc [] = pure acc
go (accL, accR) ((mb_pkg, L _ imp):imports) = do
- found <- findImportedModule fc fopts units mhome_unit imp mb_pkg
+ found <- findImportedModule hsc_env imp mb_pkg
let acc' = case found of
Found _ mod | notHomeModuleMaybe mhome_unit mod ->
case moduleUnit mod of
@@ -376,7 +366,7 @@ tcRnCheckUnit hsc_env uid =
initTc hsc_env
HsigFile -- bogus
False
- (mainModIs hsc_env)
+ (mainModIs (hsc_HUE hsc_env))
(realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
$ checkUnit uid
where
@@ -569,12 +559,7 @@ mergeSignatures
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 mhome_unit = ue_home_unit (hsc_unit_env 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.
@@ -589,7 +574,7 @@ mergeSignatures
ctx = initSDocContext dflags defaultUserStyle
fmap fst
. withException ctx
- $ findAndReadIface logger nc fc hooks unit_state mhome_unit dflags
+ $ findAndReadIface hsc_env
(text "mergeSignatures") im m NotBoot
-- STEP 3: Get the unrenamed exports of all these interfaces,
@@ -886,8 +871,9 @@ mergeSignatures
-- supposed to include itself in its dep_orphs/dep_finsts. See #13214
iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
home_unit = hsc_home_unit hsc_env
+ other_home_units = hsc_all_home_unit_ids hsc_env
avails = plusImportAvails (tcg_imports tcg_env) $
- calculateAvails home_unit iface' False NotBoot ImportedBySystem
+ calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem
return tcg_env {
tcg_inst_env = inst_env,
tcg_insts = insts,
@@ -956,6 +942,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
hsc_env <- getTopEnv
let unit_state = hsc_units hsc_env
home_unit = hsc_home_unit hsc_env
+ other_home_units = hsc_all_home_unit_ids hsc_env
addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
let insts = instUnitInsts uid
@@ -976,7 +963,7 @@ checkImplements impl_mod req_mod@(Module uid mod_name) = do
loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
(dep_orphs (mi_deps impl_iface))
- let avails = calculateAvails home_unit
+ let avails = calculateAvails home_unit other_home_units
impl_iface False{- safe -} NotBoot ImportedBySystem
fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)
| (occ, f) <- mi_fixities impl_iface
@@ -1002,14 +989,7 @@ 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
- let nc = hsc_NC hsc_env
- let fc = hsc_FC hsc_env
- let mhome_unit = ue_home_unit (hsc_unit_env 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 mhome_unit dflags
+ mb_isig_iface <- liftIO $ findAndReadIface hsc_env
(text "checkImplements 2")
isig_mod sig_mod NotBoot
isig_iface <- case mb_isig_iface of
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index f922e87876..be4facc922 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -106,7 +106,6 @@ import GHC.Core.Class
import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.External
-import GHC.Unit.Env
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -162,7 +161,7 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupGlobal_maybe hsc_env name
= do { -- Try local envt
let mod = icInteractiveModule (hsc_IC hsc_env)
- mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
+ mhome_unit = hsc_home_unit_maybe hsc_env
tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
; if nameIsLocalOrFrom tcg_semantic_mod name
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 7aad60649e..5cf866072e 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -32,7 +32,7 @@ module GHC.Tc.Utils.Monad(
getEpsVar,
getEps,
updateEps, updateEps_,
- getHpt, getEpsAndHpt,
+ getHpt, getEpsAndHug,
-- * Arrow scopes
newArrowScope, escapeArrowScope,
@@ -268,7 +268,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
let {
-- bangs to avoid leaking the env (#19356)
!dflags = hsc_dflags hsc_env ;
- !mhome_unit = ue_home_unit (hsc_unit_env hsc_env) ;
+ !mhome_unit = hsc_home_unit_maybe hsc_env;
!logger = hsc_logger hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
@@ -597,9 +597,9 @@ updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ()))
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
-getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
-getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
- ; return (eps, hsc_HPT env) }
+getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
+getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
+ ; return (eps, hsc_HUG env) }
-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing
-- an exception if it is an error.
@@ -2073,7 +2073,7 @@ initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; hsc_env <- getTopEnv
-- bangs to avoid leaking the envs (#19356)
- ; let !mhome_unit = ue_home_unit (hsc_unit_env hsc_env)
+ ; let !mhome_unit = hsc_home_unit_maybe hsc_env
!knot_vars = tcg_type_env_var tcg_env
-- When we are instantiating a signature, we DEFINITELY
-- do not want to knot tie.
diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs
index 96a60b61ae..27eb17afed 100644
--- a/compiler/GHC/Types/Name/Ppr.hs
+++ b/compiler/GHC/Types/Name/Ppr.hs
@@ -72,7 +72,7 @@ mkPrintUnqualified unit_env env
(mkQualPackage unit_state)
where
unit_state = ue_units unit_env
- home_unit = ue_home_unit unit_env
+ home_unit = ue_homeUnit unit_env
qual_name mod occ
| [gre] <- unqual_gres
, right_name gre
diff --git a/compiler/GHC/Types/PkgQual.hs b/compiler/GHC/Types/PkgQual.hs
index 2ac5894d72..9154ae7578 100644
--- a/compiler/GHC/Types/PkgQual.hs
+++ b/compiler/GHC/Types/PkgQual.hs
@@ -3,6 +3,7 @@
module GHC.Types.PkgQual where
+import GHC.Prelude
import GHC.Types.SourceText
import GHC.Unit.Types
import GHC.Utils.Outputable
@@ -23,7 +24,7 @@ data PkgQual
= NoPkgQual -- ^ No package qualifier
| ThisPkg UnitId -- ^ Import from home-unit
| OtherPkg UnitId -- ^ Import from another unit
- deriving (Data)
+ deriving (Data, Ord, Eq)
instance Outputable RawPkgQual where
ppr = \case
@@ -34,7 +35,7 @@ instance Outputable RawPkgQual where
instance Outputable PkgQual where
ppr = \case
NoPkgQual -> empty
- ThisPkg _ -> doubleQuotes (text "this")
+ ThisPkg u -> doubleQuotes (ppr u)
OtherPkg u -> doubleQuotes (ppr u)
diff --git a/compiler/GHC/Types/Target.hs b/compiler/GHC/Types/Target.hs
index 191f84eb2f..8622156caf 100644
--- a/compiler/GHC/Types/Target.hs
+++ b/compiler/GHC/Types/Target.hs
@@ -55,8 +55,8 @@ type InputFileBuffer = StringBuffer
pprTarget :: Target -> SDoc
-pprTarget Target { targetId = id, targetAllowObjCode = obj } =
- (if obj then empty else char '*') <> pprTargetId id
+pprTarget Target { targetUnitId = uid, targetId = id, targetAllowObjCode = obj } =
+ (if obj then empty else char '*') <> ppr uid <> colon <> pprTargetId id
instance Outputable Target where
ppr = pprTarget
diff --git a/compiler/GHC/Unit.hs b/compiler/GHC/Unit.hs
index d5d338e549..155d5b3525 100644
--- a/compiler/GHC/Unit.hs
+++ b/compiler/GHC/Unit.hs
@@ -24,7 +24,7 @@ import GHC.Unit.State
Note [About Units]
~~~~~~~~~~~~~~~~~~
-Haskell users are used to manipulate Cabal packages. These packages are
+Haskell users are used to manipulating Cabal packages. These packages are
identified by:
- a package name :: String
- a package version :: Version
diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs
index 2655bb166c..c3b7aaed4a 100644
--- a/compiler/GHC/Unit/Env.hs
+++ b/compiler/GHC/Unit/Env.hs
@@ -1,11 +1,61 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
module GHC.Unit.Env
( UnitEnv (..)
, initUnitEnv
, unsafeGetHomeUnit
+ , updateHug
, updateHpt
+ -- * Unit Env helper functions
+ , ue_units
+ , ue_currentHomeUnitEnv
+ , ue_setUnits
+ , ue_setUnitFlags
+ , ue_unit_dbs
+ , ue_setUnitDbs
+ , ue_hpt
+ , ue_homeUnit
+ , ue_unsafeHomeUnit
+ , ue_setFlags
+ , ue_setActiveUnit
+ , ue_currentUnit
+ , ue_findHomeUnitEnv
+ , ue_updateHomeUnitEnv
+ , ue_unitHomeUnit
+ , ue_unitFlags
+ , ue_renameUnitId
+ , ue_transitiveHomeDeps
+ -- * HomeUnitEnv
+ , HomeUnitGraph
+ , HomeUnitEnv (..)
+ , mkHomeUnitEnv
+ , lookupHugByModule
+ , hugElts
+ , lookupHug
+ , addHomeModInfoToHug
+ -- * UnitEnvGraph
+ , UnitEnvGraph (..)
+ , unitEnv_insert
+ , unitEnv_delete
+ , unitEnv_adjust
+ , unitEnv_new
+ , unitEnv_singleton
+ , unitEnv_map
+ , unitEnv_member
+ , unitEnv_lookup_maybe
+ , unitEnv_lookup
+ , unitEnv_keys
+ , unitEnv_elts
+ , unitEnv_hpts
+ , unitEnv_foldWithKey
+ , unitEnv_mapWithKey
+ -- * Invariants
+ , assertUnitEnvInvariant
+ -- * Preload units info
, preloadUnitsInfo
, preloadUnitsInfo'
- )
+ -- * Home Module functions
+ , isUnitEnvInstalledModule )
where
import GHC.Prelude
@@ -20,48 +70,26 @@ import GHC.Platform
import GHC.Settings
import GHC.Data.Maybe
import GHC.Utils.Panic.Plain
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import GHC.Utils.Misc (HasDebugCallStack)
+import GHC.Driver.Session
+import GHC.Utils.Outputable
+import GHC.Utils.Panic (pprPanic)
+import GHC.Unit.Module.ModIface
+import GHC.Unit.Module
+import qualified Data.Set as Set
data UnitEnv = UnitEnv
- { ue_units :: !UnitState
- -- ^ External units
-
- , ue_unit_dbs :: !(Maybe [UnitDatabase UnitId])
- -- ^ Stack of unit databases for the target platform.
- --
- -- This field is populated with the result of `initUnits`.
- --
- -- 'Nothing' means the databases have never been read from disk.
- --
- -- Usually we don't reload the databases from disk if they are
- -- cached, even if the database flags changed!
-
- , ue_eps :: {-# UNPACK #-} !ExternalUnitCache
+ { ue_eps :: {-# UNPACK #-} !ExternalUnitCache
-- ^ Information about the currently loaded external packages.
-- This is mutable because packages will be demand-loaded during
-- a compilation run as required.
- , ue_home_unit :: !(Maybe HomeUnit)
- -- ^ Home unit
-
- , ue_hpt :: !HomePackageTable
- -- ^ The home package table describes already-compiled
- -- home-package modules, /excluding/ the module we
- -- are compiling right now.
- -- (In one-shot mode the current module is the only
- -- home-package module, so hsc_HPT is empty. All other
- -- modules count as \"external-package\" modules.
- -- However, even in GHCi mode, hi-boot interfaces are
- -- demand-loaded into the external-package table.)
- --
- -- 'hsc_HPT' is not mutable because we only demand-load
- -- external packages; the home package is eagerly
- -- loaded, module by module, by the compilation manager.
- --
- -- The HPT may contain modules compiled earlier by @--make@
- -- but not actually below the current module in the dependency
- -- graph.
- --
- -- (This changes a previous invariant: changed Jan 05.)
+ , ue_current_unit :: UnitId
+
+ , ue_home_unit_graph :: !HomeUnitGraph
+ -- See Note [Multiple Home Units]
, ue_platform :: !Platform
-- ^ Platform
@@ -70,29 +98,39 @@ data UnitEnv = UnitEnv
-- ^ GHC name/version (used for dynamic library suffix)
}
-initUnitEnv :: GhcNameVersion -> Platform -> IO UnitEnv
-initUnitEnv namever platform = do
+initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
+initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
return $ UnitEnv
- { ue_units = emptyUnitState
- , ue_unit_dbs = Nothing
- , ue_eps = eps
- , ue_home_unit = Nothing
- , ue_hpt = emptyHomePackageTable
- , ue_platform = platform
- , ue_namever = namever
+ { ue_eps = eps
+ , ue_home_unit_graph = hug
+ , ue_current_unit = cur_unit
+ , ue_platform = platform
+ , ue_namever = namever
}
-- | Get home-unit
--
-- Unsafe because the home-unit may not be set
unsafeGetHomeUnit :: UnitEnv -> HomeUnit
-unsafeGetHomeUnit ue = case ue_home_unit ue of
- Nothing -> panic "unsafeGetHomeUnit: No home unit"
- Just h -> h
+unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue
updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv
-updateHpt f ue = ue { ue_hpt = f (ue_hpt ue) }
+updateHpt = ue_updateHPT
+
+updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
+updateHug = ue_updateHUG
+
+ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId]
+ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid])
+ where
+ loop acc [] = acc
+ loop acc (uid:uids)
+ | uid `Set.member` acc = loop acc uids
+ | otherwise =
+ let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env))
+ in loop (Set.insert uid acc) (hue ++ uids)
+
-- -----------------------------------------------------------------------------
-- Extracting information from the packages in scope
@@ -113,7 +151,7 @@ preloadUnitsInfo' unit_env ids0 = all_infos
where
unit_state = ue_units unit_env
ids = ids0 ++ inst_ids
- inst_ids = case ue_home_unit unit_env of
+ inst_ids = case ue_homeUnit unit_env of
Nothing -> []
Just home_unit
-- An indefinite package will have insts to HOLE,
@@ -132,3 +170,401 @@ preloadUnitsInfo' unit_env ids0 = all_infos
-- unit used to instantiate the home unit.
preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env []
+
+-- -----------------------------------------------------------------------------
+
+data HomeUnitEnv = HomeUnitEnv
+ { homeUnitEnv_units :: !UnitState
+ -- ^ External units
+
+ , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])
+ -- ^ Stack of unit databases for the target platform.
+ --
+ -- This field is populated with the result of `initUnits`.
+ --
+ -- 'Nothing' means the databases have never been read from disk.
+ --
+ -- Usually we don't reload the databases from disk if they are
+ -- cached, even if the database flags changed!
+
+ , homeUnitEnv_dflags :: DynFlags
+ -- ^ The dynamic flag settings
+ , homeUnitEnv_hpt :: HomePackageTable
+ -- ^ The home package table describes already-compiled
+ -- home-package modules, /excluding/ the module we
+ -- are compiling right now.
+ -- (In one-shot mode the current module is the only
+ -- home-package module, so homeUnitEnv_hpt is empty. All other
+ -- modules count as \"external-package\" modules.
+ -- However, even in GHCi mode, hi-boot interfaces are
+ -- demand-loaded into the external-package table.)
+ --
+ -- 'homeUnitEnv_hpt' is not mutable because we only demand-load
+ -- external packages; the home package is eagerly
+ -- loaded, module by module, by the compilation manager.
+ --
+ -- The HPT may contain modules compiled earlier by @--make@
+ -- but not actually below the current module in the dependency
+ -- graph.
+ --
+ -- (This changes a previous invariant: changed Jan 05.)
+
+ , homeUnitEnv_home_unit :: !(Maybe HomeUnit)
+ -- ^ Home-unit
+ }
+
+instance Outputable HomeUnitEnv where
+ ppr hug = pprHPT (homeUnitEnv_hpt hug)
+
+homeUnitEnv_unsafeHomeUnit :: HomeUnitEnv -> HomeUnit
+homeUnitEnv_unsafeHomeUnit hue = case homeUnitEnv_home_unit hue of
+ Nothing -> panic "homeUnitEnv_unsafeHomeUnit: No home unit"
+ Just h -> h
+
+mkHomeUnitEnv :: DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
+mkHomeUnitEnv dflags hpt home_unit = HomeUnitEnv
+ { homeUnitEnv_units = emptyUnitState
+ , homeUnitEnv_unit_dbs = Nothing
+ , homeUnitEnv_dflags = dflags
+ , homeUnitEnv_hpt = hpt
+ , homeUnitEnv_home_unit = home_unit
+ }
+
+-- | Test if the module comes from the home unit
+isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool
+isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu
+ where
+ hu = ue_unitHomeUnit_maybe (moduleUnit m) ue
+
+
+type HomeUnitGraph = UnitEnvGraph HomeUnitEnv
+
+lookupHugByModule :: Module -> HomeUnitGraph -> Maybe HomeModInfo
+lookupHugByModule mod hug
+ | otherwise = do
+ env <- (unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug)
+ lookupHptByModule (homeUnitEnv_hpt env) mod
+
+hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)]
+hugElts hug = unitEnv_elts hug
+
+addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
+addHomeModInfoToHug hmi hug = unitEnv_alter go hmi_unit hug
+ where
+ hmi_mod :: Module
+ hmi_mod = mi_module (hm_iface hmi)
+
+ hmi_unit = toUnitId (moduleUnit hmi_mod)
+ _hmi_mn = moduleName hmi_mod
+
+ go :: Maybe HomeUnitEnv -> Maybe HomeUnitEnv
+ go Nothing = pprPanic "addHomeInfoToHug" (ppr hmi_mod)
+ go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue)
+
+updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv
+updateHueHpt f hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue)}
+
+
+lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo
+lookupHug hug uid mod = unitEnv_lookup_maybe uid hug >>= flip lookupHpt mod . homeUnitEnv_hpt
+
+
+instance Outputable (UnitEnvGraph HomeUnitEnv) where
+ ppr g = ppr [(k, length (homeUnitEnv_hpt hue)) | (k, hue) <- (unitEnv_elts g)]
+
+
+type UnitEnvGraphKey = UnitId
+
+newtype UnitEnvGraph v = UnitEnvGraph
+ { unitEnv_graph :: Map UnitEnvGraphKey v
+ } deriving (Functor, Foldable, Traversable)
+
+unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v
+unitEnv_insert unitId env unitEnv = unitEnv
+ { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)
+ }
+
+unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v
+unitEnv_delete uid unitEnv =
+ unitEnv
+ { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv)
+ }
+
+unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v
+unitEnv_adjust f uid unitEnv = unitEnv
+ { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv)
+ }
+
+unitEnv_alter :: (Maybe v -> Maybe v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v
+unitEnv_alter f uid unitEnv = unitEnv
+ { unitEnv_graph = Map.alter f uid (unitEnv_graph unitEnv)
+ }
+
+unitEnv_mapWithKey :: (UnitEnvGraphKey -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b
+unitEnv_mapWithKey f (UnitEnvGraph u) = UnitEnvGraph $ Map.mapWithKey f u
+
+unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v
+unitEnv_new m =
+ UnitEnvGraph
+ { unitEnv_graph = m
+ }
+
+unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v
+unitEnv_singleton active m = UnitEnvGraph
+ { unitEnv_graph = Map.singleton active m
+ }
+
+unitEnv_map :: (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v
+unitEnv_map f m = m { unitEnv_graph = Map.map f (unitEnv_graph m)}
+
+unitEnv_member :: UnitEnvGraphKey -> UnitEnvGraph v -> Bool
+unitEnv_member u env = Map.member u (unitEnv_graph env)
+
+unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v
+unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env)
+
+unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v
+unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env
+
+unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey
+unitEnv_keys env = Map.keysSet (unitEnv_graph env)
+
+unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)]
+unitEnv_elts env = Map.toList (unitEnv_graph env)
+
+unitEnv_hpts :: UnitEnvGraph HomeUnitEnv -> [HomePackageTable]
+unitEnv_hpts env = map homeUnitEnv_hpt (Map.elems (unitEnv_graph env))
+
+unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b
+unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g
+
+-- -------------------------------------------------------
+-- Query and modify UnitState in HomeUnitEnv
+-- -------------------------------------------------------
+
+ue_units :: HasDebugCallStack => UnitEnv -> UnitState
+ue_units = homeUnitEnv_units . ue_currentHomeUnitEnv
+
+ue_setUnits :: UnitState -> UnitEnv -> UnitEnv
+ue_setUnits units ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue
+ where
+ f hue = hue { homeUnitEnv_units = units }
+
+ue_unit_dbs :: UnitEnv -> Maybe [UnitDatabase UnitId]
+ue_unit_dbs = homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv
+
+ue_setUnitDbs :: Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv
+ue_setUnitDbs unit_dbs ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue
+ where
+ f hue = hue { homeUnitEnv_unit_dbs = unit_dbs }
+
+-- -------------------------------------------------------
+-- Query and modify Home Package Table in HomeUnitEnv
+-- -------------------------------------------------------
+
+ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable
+ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv
+
+ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv
+ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e
+
+ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
+ue_updateHUG f e = ue_updateUnitHUG f e
+
+ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv
+ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env
+ where
+ update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv }
+
+ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
+ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)}
+
+-- -------------------------------------------------------
+-- Query and modify DynFlags in HomeUnitEnv
+-- -------------------------------------------------------
+
+ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv
+ue_setFlags dflags ue_env = ue_setUnitFlags (ue_currentUnit ue_env) dflags ue_env
+
+ue_setUnitFlags :: HasDebugCallStack => UnitId -> DynFlags -> UnitEnv -> UnitEnv
+ue_setUnitFlags uid dflags e =
+ ue_updateUnitFlags (const dflags) uid e
+
+ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags
+ue_unitFlags uid ue_env = homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env
+
+ue_updateUnitFlags :: HasDebugCallStack => (DynFlags -> DynFlags) -> UnitId -> UnitEnv -> UnitEnv
+ue_updateUnitFlags f uid e = ue_updateHomeUnitEnv update uid e
+ where
+ update hue = hue { homeUnitEnv_dflags = f $ homeUnitEnv_dflags hue }
+
+-- -------------------------------------------------------
+-- Query and modify home units in HomeUnitEnv
+-- -------------------------------------------------------
+
+ue_homeUnit :: UnitEnv -> Maybe HomeUnit
+ue_homeUnit = homeUnitEnv_home_unit . ue_currentHomeUnitEnv
+
+ue_unsafeHomeUnit :: UnitEnv -> HomeUnit
+ue_unsafeHomeUnit ue = case ue_homeUnit ue of
+ Nothing -> panic "unsafeGetHomeUnit: No home unit"
+ Just h -> h
+
+ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
+ue_unitHomeUnit_maybe uid ue_env =
+ homeUnitEnv_unsafeHomeUnit <$> (ue_findHomeUnitEnv_maybe uid ue_env)
+
+ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit
+ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env
+
+
+-- -------------------------------------------------------
+-- Query and modify the currently active unit
+-- -------------------------------------------------------
+
+ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv
+ue_currentHomeUnitEnv e =
+ case ue_findHomeUnitEnv_maybe (ue_currentUnit e) e of
+ Just unitEnv -> unitEnv
+ Nothing -> pprPanic "packageNotFound" $
+ (ppr $ ue_currentUnit e) $$ ppr (ue_home_unit_graph e)
+
+ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv
+ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env
+ { ue_current_unit = u
+ }
+
+ue_currentUnit :: UnitEnv -> UnitId
+ue_currentUnit = ue_current_unit
+
+-- -------------------------------------------------------
+-- Operations on arbitrary elements of the home unit graph
+-- -------------------------------------------------------
+
+ue_findHomeUnitEnv_maybe :: UnitId -> UnitEnv -> Maybe HomeUnitEnv
+ue_findHomeUnitEnv_maybe uid e =
+ unitEnv_lookup_maybe uid (ue_home_unit_graph e)
+
+ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
+ue_findHomeUnitEnv uid e = case unitEnv_lookup_maybe uid (ue_home_unit_graph e) of
+ Nothing -> pprPanic "Unit unknown to the internal unit environment"
+ $ text "unit (" <> ppr uid <> text ")"
+ $$ pprUnitEnvGraph e
+ Just hue -> hue
+
+ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv
+ue_updateHomeUnitEnv f uid e = e
+ { ue_home_unit_graph = unitEnv_adjust f uid $ ue_home_unit_graph e
+ }
+
+
+-- | Rename a unit id in the internal unit env.
+--
+-- @'ue_renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the map,
+-- otherwise we panic.
+-- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'.
+ue_renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv
+ue_renameUnitId oldUnit newUnit unitEnv = case ue_findHomeUnitEnv_maybe oldUnit unitEnv of
+ Nothing ->
+ pprPanic "Tried to rename unit, but it didn't exist"
+ $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\""
+ $$ nest 2 (pprUnitEnvGraph unitEnv)
+ Just oldEnv ->
+ let
+ activeUnit :: UnitId
+ !activeUnit = if ue_currentUnit unitEnv == oldUnit
+ then newUnit
+ else ue_currentUnit unitEnv
+
+ newInternalUnitEnv = oldEnv
+ { homeUnitEnv_dflags = (homeUnitEnv_dflags oldEnv)
+ { homeUnitId_ = newUnit
+ }
+ }
+ in
+ unitEnv
+ { ue_current_unit = activeUnit
+ , ue_home_unit_graph =
+ unitEnv_insert newUnit newInternalUnitEnv
+ $ unitEnv_delete oldUnit
+ $ ue_home_unit_graph unitEnv
+ }
+
+-- ---------------------------------------------
+-- Asserts to enforce invariants for the UnitEnv
+-- ---------------------------------------------
+
+assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv
+assertUnitEnvInvariant u =
+ if ue_current_unit u `unitEnv_member` ue_home_unit_graph u
+ then u
+ else pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (ue_home_unit_graph u))
+
+-- -----------------------------------------------------------------------------
+-- Pretty output functions
+-- -----------------------------------------------------------------------------
+
+pprUnitEnvGraph :: UnitEnv -> SDoc
+pprUnitEnvGraph env = text "pprInternalUnitMap"
+ $$ nest 2 (pprHomeUnitGraph $ ue_home_unit_graph env)
+
+pprHomeUnitGraph :: HomeUnitGraph -> SDoc
+pprHomeUnitGraph unitEnv = vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv)
+
+pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> SDoc
+pprHomeUnitEnv uid env =
+ ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"
+ $$ nest 4 (pprHPT $ homeUnitEnv_hpt env)
+
+{-
+Note [Multiple Home Units]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of multiple home units is quite simple. Instead of allowing one
+home unit, you can multiple home units
+
+The flow:
+
+1. Dependencies between units are specified between each other in the normal manner,
+ a unit is identified by the -this-unit-id flag and dependencies specified by
+ the normal -package-id flag.
+2. Downsweep is augmented to know to know how to look for dependencies in any home unit.
+3. The rest of the compiler is modified appropiately to offset paths to the right places.
+4. --make mode can parallelise between home units and multiple units are allowed to produce linkables.
+
+Closure Property
+----------------
+
+You must perform a clean cut of the dependency graph.
+
+> Any dependency which is not a home unit must not (transitively) depend on a home unit.
+
+For example, if you have three packages p, q and r, then if p depends on q which
+depends on r then it is illegal to load both p and r as home units but not q,
+because q is a dependency of the home unit p which depends on another home unit r.
+
+Offsetting Paths
+----------------
+
+The main complication to the implementation is to do with offsetting paths appropiately.
+For a long time it has been assumed that GHC will execute in the top-directory for a unit,
+normally where the .cabal file is and all paths are interpreted relative to there.
+When you have multiple home units then it doesn't make sense to pick one of these
+units to choose as the base-unit, and you can't robustly change directories when
+using parralelism.
+
+Therefore there is an option `-working-directory`, which tells GHC where the relative
+paths for each unit should be interpreted relative to. For example, if you specify
+`-working-dir a -ib`, then GHC will offset the relative path `b`, by `a`, and look for
+source files in `a/b`. The same thing happens for any path passed on the command line.
+
+A non-exhaustive list is
+
+* -i
+* -I
+* -odir/-hidir/-outputdir/-stubdir/-hiedir
+* Target files passed on the command line
+
+There is also a template-haskell function, makeRelativeToProject, which uses the `-working-directory` option
+in order to allow users to offset their own relative paths.
+
+-}
diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs
index 177a9db2ba..4ed3479bf4 100644
--- a/compiler/GHC/Unit/External.hs
+++ b/compiler/GHC/Unit/External.hs
@@ -30,7 +30,6 @@ import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv )
import GHC.Types.CompleteMatch
import GHC.Types.TypeEnv
import GHC.Types.Unique.DSet
-import GHC.Types.Unique.FM
import Data.IORef
@@ -62,7 +61,7 @@ initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState
initExternalPackageState :: ExternalPackageState
initExternalPackageState = EPS
- { eps_is_boot = emptyUFM
+ { eps_is_boot = emptyInstalledModuleEnv
, eps_PIT = emptyPackageIfaceTable
, eps_free_holes = emptyInstalledModuleEnv
, eps_PTE = emptyTypeEnv
@@ -89,7 +88,7 @@ initExternalPackageState = EPS
-- their interface files
data ExternalPackageState
= EPS {
- eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),
+ eps_is_boot :: !(InstalledModuleEnv ModuleNameWithIsBoot),
-- ^ In OneShot mode (only), home-package modules
-- accumulate in the external package state, and are
-- sucked in lazily. For these home-pkg modules
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index d4de80947b..c7b6a2eb65 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
-- | Module finder
module GHC.Unit.Finder (
@@ -24,6 +25,7 @@ module GHC.Unit.Finder (
mkHiOnlyModLocation,
mkHiPath,
mkObjPath,
+ addModuleToFinder,
addHomeModuleToFinder,
uncacheModule,
mkStubPaths,
@@ -41,6 +43,7 @@ import GHC.Platform.Ways
import GHC.Builtin.Names ( gHC_PRIM )
+import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Unit.Home
@@ -64,7 +67,10 @@ import System.FilePath
import Control.Monad
import Data.Time
import qualified Data.Map as M
-
+import GHC.Driver.Env
+ ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
+import GHC.Driver.Config.Finder
+import qualified Data.Set as Set
type FileExt = String -- Filename extension
type BaseName = String -- Basename of file
@@ -90,12 +96,12 @@ initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv
-- remove all the home modules from the cache; package modules are
-- assumed to not move around during a session; also flush the file hash
-- cache
-flushFinderCaches :: FinderCache -> HomeUnit -> IO ()
-flushFinderCaches (FinderCache ref file_ref) home_unit = do
+flushFinderCaches :: FinderCache -> UnitEnv -> IO ()
+flushFinderCaches (FinderCache ref file_ref) ue = do
atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_ref $ \_ -> (M.empty, ())
where
- is_ext mod _ = not (isHomeInstalledModule home_unit mod)
+ is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
addToFinderCache (FinderCache ref _) key val =
@@ -130,32 +136,66 @@ lookupFileCache (FinderCache _ ref) key = do
-- packages to find the module, if a package is specified then only
-- that package is searched for the module.
-findImportedModule
+findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
+findImportedModule hsc_env mod fs =
+ let fc = hsc_FC hsc_env
+ mhome_unit = hsc_home_unit_maybe hsc_env
+ dflags = hsc_dflags hsc_env
+ fopts = initFinderOpts dflags
+ in do
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs
+
+findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
- -> UnitState
+ -> UnitEnv
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModule fc fopts units mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
- ThisPkg _ -> home_import
+ ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
+ | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
+ | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
OtherPkg _ -> pkg_import
where
- home_import
- | Just home_unit <- mhome_unit
- = findHomeModule fc fopts home_unit mod_name
- | otherwise
- = pure $ NoPackage (panic "findImportedModule: no home-unit")
+ all_opts = case mhome_unit of
+ Nothing -> other_fopts
+ Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
+
+
+ home_import = case mhome_unit of
+ Just home_unit -> findHomeModule fc fopts home_unit mod_name
+ Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")
+
+
+ home_pkg_import (uid, opts)
+ -- If the module is reexported, then look for it as if it was from the perspective
+ -- of that package which reexports it.
+ | mod_name `Set.member` finder_reexportedModules opts =
+ findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
+ | mod_name `Set.member` finder_hiddenModules opts =
+ return (mkHomeHidden uid)
+ | otherwise =
+ findHomePackageModule fc opts uid mod_name
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)
- unqual_import = home_import
+ pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+
+ unqual_import = any_home_import
`orIfNotFound`
findExposedPackageModule fc fopts units mod_name NoPkgQual
+ units = case mhome_unit of
+ Nothing -> ue_units ue
+ Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
+ hpt_deps :: [UnitId]
+ hpt_deps = homeUnitDepends units
+ other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
+
-- | 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
@@ -174,12 +214,14 @@ findPluginModule fc fopts units Nothing mod_name =
-- reading the interface for a module mentioned by another interface,
-- for example (a "system import").
-findExactModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
-findExactModule fc fopts unit_state mhome_unit mod = do
+findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
+findExactModule fc fopts other_fopts unit_state mhome_unit mod = do
case mhome_unit of
Just home_unit
- | isHomeInstalledModule home_unit mod
- -> findInstalledHomeModule fc fopts home_unit (moduleName mod)
+ | isHomeInstalledModule home_unit mod
+ -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
+ | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts
+ -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
_ -> findPackageModule fc unit_state fopts mod
-- -----------------------------------------------------------------------------
@@ -215,9 +257,9 @@ 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 :: FinderCache -> HomeUnit -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
+homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
homeSearchCache fc home_unit mod_name do_this = do
- let mod = mkHomeInstalledModule home_unit mod_name
+ let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
@@ -285,6 +327,11 @@ modLocationCache fc mod do_this = do
addToFinderCache fc mod result
return result
+addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()
+addModuleToFinder fc mod loc = do
+ let imod = toUnitId <$> mod
+ addToFinderCache fc imod (InstalledFound loc imod)
+
-- This returns a module because it's more convenient for users
addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
addHomeModuleToFinder fc home_unit mod_name loc = do
@@ -303,7 +350,7 @@ uncacheModule fc home_unit mod_name = do
findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
findHomeModule fc fopts home_unit mod_name = do
let uid = homeUnitAsUnit home_unit
- r <- findInstalledHomeModule fc fopts home_unit mod_name
+ r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
return $ case r of
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
@@ -316,6 +363,32 @@ findHomeModule fc fopts home_unit mod_name = do
fr_suggestions = []
}
+mkHomeHidden :: UnitId -> FindResult
+mkHomeHidden uid =
+ NotFound { fr_paths = []
+ , fr_pkg = Just (RealUnit (Definite uid))
+ , fr_mods_hidden = [RealUnit (Definite uid)]
+ , fr_pkgs_hidden = []
+ , fr_unusables = []
+ , fr_suggestions = []}
+
+findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult
+findHomePackageModule fc fopts home_unit mod_name = do
+ let uid = RealUnit (Definite home_unit)
+ r <- findInstalledHomeModule fc fopts home_unit mod_name
+ return $ case r of
+ InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+ InstalledNoPackage _ -> NoPackage uid -- impossible
+ InstalledNotFound fps _ -> NotFound {
+ fr_paths = fps,
+ fr_pkg = Just uid,
+ fr_mods_hidden = [],
+ fr_pkgs_hidden = [],
+ fr_unusables = [],
+ fr_suggestions = []
+ }
+
+
-- | 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
-- as a building block for the following operations:
@@ -332,13 +405,16 @@ findHomeModule fc fopts home_unit mod_name = do
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
-- call this.)
-findInstalledHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO InstalledFindResult
+findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult
findInstalledHomeModule fc fopts home_unit mod_name = do
homeSearchCache fc home_unit mod_name $
let
- home_path = finder_importPaths fopts
+ maybe_working_dir = finder_workingDirectory fopts
+ home_path = case maybe_working_dir of
+ Nothing -> finder_importPaths fopts
+ Just fp -> augmentImports fp (finder_importPaths fopts)
hisuf = finder_hiSuf fopts
- mod = mkHomeInstalledModule home_unit mod_name
+ mod = mkModule home_unit mod_name
source_exts =
[ ("hs", mkHomeModLocationSearched fopts mod_name "hs")
@@ -367,6 +443,11 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
then return (InstalledFound (error "GHC.Prim ModLocation") mod)
else searchPathExts home_path mod exts
+-- | Prepend the working directory to the search path.
+augmentImports :: FilePath -> [FilePath] -> [FilePath]
+augmentImports _work_dir [] = []
+augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
+ | otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs
index 26baea564c..d3dad77eda 100644
--- a/compiler/GHC/Unit/Finder/Types.hs
+++ b/compiler/GHC/Unit/Finder/Types.hs
@@ -14,6 +14,8 @@ import GHC.Fingerprint
import GHC.Platform.Ways
import Data.IORef
+import GHC.Data.FastString
+import qualified Data.Set as Set
-- | The 'FinderCache' maps modules to the result of
-- searching for that module. It records the results of searching for
@@ -86,6 +88,10 @@ data FinderOpts = FinderOpts
, finder_enableSuggestions :: Bool
-- ^ If we encounter unknown modules, should we suggest modules
-- that have a similar name.
+ , finder_workingDirectory :: Maybe FilePath
+ , finder_thisPackageName :: Maybe FastString
+ , finder_hiddenModules :: Set.Set ModuleName
+ , finder_reexportedModules :: Set.Set ModuleName
, finder_hieDir :: Maybe FilePath
, finder_hieSuf :: String
, finder_hiDir :: Maybe FilePath
@@ -95,4 +101,4 @@ data FinderOpts = FinderOpts
, finder_objectSuf :: String
, finder_dynObjectSuf :: String
, finder_stubDir :: Maybe FilePath
- }
+ } deriving Show
diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs
index 2173b7431b..d66019a3ea 100644
--- a/compiler/GHC/Unit/Home/ModInfo.hs
+++ b/compiler/GHC/Unit/Home/ModInfo.hs
@@ -132,7 +132,6 @@ lookupHptByModule hpt mod
pprHPT :: HomePackageTable -> SDoc
-- A bit arbitrary for now
pprHPT hpt = pprUDFM hpt $ \hms ->
- vcat [ hang (ppr (mi_module (hm_iface hm)))
- 2 (ppr (md_types (hm_details hm)))
+ vcat [ ppr (mi_module (hm_iface hm))
| hm <- hms ]
diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs
index 0ebfa73d16..b9813b95f5 100644
--- a/compiler/GHC/Unit/Module.hs
+++ b/compiler/GHC/Unit/Module.hs
@@ -108,7 +108,7 @@ getModuleInstantiation m =
getUnitInstantiations :: Unit -> (UnitId, Maybe InstantiatedUnit)
getUnitInstantiations (VirtUnit iuid) = (instUnitInstanceOf iuid, Just iuid)
getUnitInstantiations (RealUnit (Definite uid)) = (uid, Nothing)
-getUnitInstantiations HoleUnit = error "Hole unit"
+getUnitInstantiations (HoleUnit {}) = error "Hole unit"
-- | Remove instantiations of the given instantiated unit
uninstantiateInstantiatedUnit :: InstantiatedUnit -> InstantiatedUnit
diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs
index 73412c002c..3a59703f88 100644
--- a/compiler/GHC/Unit/Module/Deps.hs
+++ b/compiler/GHC/Unit/Module/Deps.hs
@@ -23,7 +23,6 @@ import GHC.Prelude
import GHC.Types.SafeHaskell
import GHC.Types.Name
-import GHC.Types.Unique.FM
import GHC.Unit.Module.Name
import GHC.Unit.Module.Imported
@@ -38,6 +37,7 @@ import GHC.Utils.Outputable
import Data.List (sortBy, sort, partition)
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Bifunctor
-- | Dependency information about ALL modules and packages below this one
-- in the import hierarchy. This is the serialisable version of `ImportAvails`.
@@ -50,7 +50,7 @@ import qualified Data.Set as Set
--
-- See Note [Transitive Information in Dependencies]
data Dependencies = Deps
- { dep_direct_mods :: Set ModuleNameWithIsBoot
+ { dep_direct_mods :: Set (UnitId, ModuleNameWithIsBoot)
-- ^ All home-package modules which are directly imported by this one.
, dep_direct_pkgs :: Set UnitId
@@ -72,7 +72,7 @@ data Dependencies = Deps
-- when the module is imported as a safe import
-- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names
- , dep_boot_mods :: Set ModuleNameWithIsBoot
+ , dep_boot_mods :: Set (UnitId, ModuleNameWithIsBoot)
-- ^ All modules which have boot files below this one, and whether we
-- should use the boot file or not.
-- This information is only used to populate the eps_is_boot field.
@@ -109,15 +109,15 @@ mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies
mkDependencies home_unit mod imports plugin_mods =
let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods
plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins)
- all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot))
+ all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot))
(imp_direct_dep_mods imports)
- (map moduleName home_plugins)
+ (map (fmap toUnitId) home_plugins)
- modDepsElts = Set.fromList . nonDetEltsUFM
+ modDepsElts = Set.fromList . installedModuleEnvElts
-- It's OK to use nonDetEltsUFM here because sorting by module names
-- restores determinism
- direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod))
+ direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod))
-- M.hi-boot can be in the imp_dep_mods, but we must remove
-- it before recording the modules on which this one depends!
-- (We want to retain M.hi-boot in imp_dep_mods so that
@@ -137,7 +137,7 @@ mkDependencies home_unit mod imports plugin_mods =
-- If there's a non-boot import, then it shadows the boot import
-- coming from the dependencies
- source_mods = modDepsElts (imp_boot_mods imports)
+ source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports)
sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports
@@ -227,8 +227,8 @@ pprDeps unit_state (Deps { dep_direct_mods = dmods
text "family instance modules:" <+> fsep (map ppr finsts)
]
where
- ppr_mod (GWIB mod IsBoot) = ppr mod <+> text "[boot]"
- ppr_mod (GWIB mod NotBoot) = ppr mod
+ ppr_mod (uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]"
+ ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod
ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc
ppr_set w = fsep . fmap w . Set.toAscList
@@ -478,7 +478,7 @@ data ImportAvails
-- different packages. (currently not the case, but might be in the
-- future).
- imp_direct_dep_mods :: ModuleNameEnv ModuleNameWithIsBoot,
+ imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot,
-- ^ Home-package modules directly imported by the module being compiled.
imp_dep_direct_pkgs :: Set UnitId,
@@ -499,7 +499,7 @@ data ImportAvails
-- we are dependent on a trustworthy module in that package.
-- See Note [Tracking Trust Transitively] in "GHC.Rename.Names"
- imp_boot_mods :: ModuleNameEnv ModuleNameWithIsBoot,
+ imp_boot_mods :: InstalledModuleEnv ModuleNameWithIsBoot,
-- ^ Domain is all modules which have hs-boot files, and whether
-- we should import the boot version of interface file. Only used
-- in one-shot mode to populate eps_is_boot.
diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs
index 905b446fe2..a69c865aef 100644
--- a/compiler/GHC/Unit/Module/Env.hs
+++ b/compiler/GHC/Unit/Module/Env.hs
@@ -28,7 +28,9 @@ module GHC.Unit.Module.Env
, extendInstalledModuleEnv
, filterInstalledModuleEnv
, delInstalledModuleEnv
+ , mergeInstalledModuleEnv
, plusInstalledModuleEnv
+ , installedModuleEnvElts
)
where
@@ -49,6 +51,7 @@ import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified GHC.Data.FiniteMap as Map
+import GHC.Utils.Outputable
-- | A map keyed off of 'Module's
newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
@@ -209,6 +212,10 @@ type DModuleNameEnv elt = UniqDFM ModuleName elt
-- | A map keyed off of 'InstalledModule'
newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt)
+instance Outputable elt => Outputable (InstalledModuleEnv elt) where
+ ppr (InstalledModuleEnv env) = ppr env
+
+
emptyInstalledModuleEnv :: InstalledModuleEnv a
emptyInstalledModuleEnv = InstalledModuleEnv Map.empty
@@ -225,6 +232,27 @@ filterInstalledModuleEnv f (InstalledModuleEnv e) =
delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a
delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e)
--- | Left-biased
-plusInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModuleEnv a -> InstalledModuleEnv a
-plusInstalledModuleEnv (InstalledModuleEnv a) (InstalledModuleEnv b) = InstalledModuleEnv (a `mappend` b)
+installedModuleEnvElts :: InstalledModuleEnv a -> [(InstalledModule, a)]
+installedModuleEnvElts (InstalledModuleEnv e) = Map.assocs e
+
+mergeInstalledModuleEnv
+ :: (elta -> eltb -> Maybe eltc)
+ -> (InstalledModuleEnv elta -> InstalledModuleEnv eltc) -- map X
+ -> (InstalledModuleEnv eltb -> InstalledModuleEnv eltc) -- map Y
+ -> InstalledModuleEnv elta
+ -> InstalledModuleEnv eltb
+ -> InstalledModuleEnv eltc
+mergeInstalledModuleEnv f g h (InstalledModuleEnv xm) (InstalledModuleEnv ym)
+ = InstalledModuleEnv $ Map.mergeWithKey
+ (\_ x y -> (x `f` y))
+ (coerce g)
+ (coerce h)
+ xm ym
+
+plusInstalledModuleEnv :: (elt -> elt -> elt)
+ -> InstalledModuleEnv elt
+ -> InstalledModuleEnv elt
+ -> InstalledModuleEnv elt
+plusInstalledModuleEnv f (InstalledModuleEnv xm) (InstalledModuleEnv ym) =
+ InstalledModuleEnv $ Map.unionWith f xm ym
+
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index 0df5779416..a225c50f27 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -6,9 +6,9 @@
module GHC.Unit.Module.Graph
( ModuleGraph
, ModuleGraphNode(..)
+ , nodeDependencies
, emptyMG
, mkModuleGraph
- , mkModuleGraph'
, extendMG
, extendMGInst
, extendMG'
@@ -16,7 +16,6 @@ module GHC.Unit.Module.Graph
, mapMG
, mgModSummaries
, mgModSummaries'
- , mgExtendedModSummaries
, mgElemModule
, mgLookupModule
, mgBootModules
@@ -36,6 +35,10 @@ module GHC.Unit.Module.Graph
, mkNodeKey
, msKey
+
+ , moduleGraphNodeUnitId
+
+ , ModNodeKeyWithUid(..)
)
where
@@ -60,9 +63,9 @@ import GHC.Utils.Outputable
import System.FilePath
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
-import GHC.Types.SrcLoc
import qualified Data.Set as Set
import GHC.Unit.Module
+import GHC.Linker.Static.Utils
-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
-- Edges between nodes mark dependencies arising from module imports
@@ -70,21 +73,51 @@ import GHC.Unit.Module
data ModuleGraphNode
-- | Instantiation nodes track the instantiation of other units
-- (backpack dependencies) with the holes (signatures) of the current package.
- = InstantiationNode InstantiatedUnit
+ = InstantiationNode UnitId InstantiatedUnit
-- | There is a module summary node for each module, signature, and boot module being built.
- | ModuleNode ExtendedModSummary
+ | ModuleNode [NodeKey] ModSummary
+ -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
+ | LinkNode [NodeKey] UnitId
-moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ExtendedModSummary
+moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName
+moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn)
+
+moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary
moduleGraphNodeModSum (InstantiationNode {}) = Nothing
-moduleGraphNodeModSum (ModuleNode ems) = Just ems
+moduleGraphNodeModSum (LinkNode {}) = Nothing
+moduleGraphNodeModSum (ModuleNode _ ms) = Just ms
-moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName
-moduleGraphNodeModule = fmap (ms_mod_name . emsModSummary) . moduleGraphNodeModSum
+moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId
+moduleGraphNodeUnitId mgn =
+ case mgn of
+ InstantiationNode uid _iud -> uid
+ ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms))
+ LinkNode _ uid -> uid
instance Outputable ModuleGraphNode where
ppr = \case
- InstantiationNode iuid -> ppr iuid
- ModuleNode ems -> ppr ems
+ InstantiationNode _ iuid -> ppr iuid
+ ModuleNode nks ms -> ppr (ms_mnwib ms) <+> ppr nks
+ LinkNode uid _ -> text "LN:" <+> ppr uid
+
+data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit
+ | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid
+ | NodeKey_Link !UnitId
+ deriving (Eq, Ord)
+
+instance Outputable NodeKey where
+ ppr nk = pprNodeKey nk
+
+pprNodeKey :: NodeKey -> SDoc
+pprNodeKey (NodeKey_Unit iu) = ppr iu
+pprNodeKey (NodeKey_Module mk) = ppr mk
+pprNodeKey (NodeKey_Link uid) = ppr uid
+
+data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot
+ , mnkUnitId :: UnitId } deriving (Eq, Ord)
+
+instance Outputable ModNodeKeyWithUid where
+ ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib
-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See
-- '@ModuleGraphNode@' for information about the nodes.
@@ -125,8 +158,9 @@ needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG f mg@ModuleGraph{..} = mg
{ mg_mss = flip fmap mg_mss $ \case
- InstantiationNode iuid -> InstantiationNode iuid
- ModuleNode (ExtendedModSummary ms bds) -> ModuleNode (ExtendedModSummary (f ms) bds)
+ InstantiationNode uid iuid -> InstantiationNode uid iuid
+ LinkNode uid nks -> LinkNode uid nks
+ ModuleNode deps ms -> ModuleNode deps (f ms)
, mg_non_boot = mapModuleEnv f mg_non_boot
}
@@ -137,10 +171,7 @@ mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey)
mgTransDeps = mg_trans_deps
mgModSummaries :: ModuleGraph -> [ModSummary]
-mgModSummaries mg = [ m | ModuleNode (ExtendedModSummary m _) <- mgModSummaries' mg ]
-
-mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]
-mgExtendedModSummaries mg = [ ems | ModuleNode ems <- mgModSummaries' mg ]
+mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ]
mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
mgModSummaries' = mg_mss
@@ -163,9 +194,9 @@ isTemplateHaskellOrQQNonBoot ms =
-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
-extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph
-extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph
- { mg_mss = ModuleNode ems : mg_mss
+extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph
+extendMG ModuleGraph{..} deps ms = ModuleGraph
+ { mg_mss = ModuleNode deps ms : mg_mss
, mg_trans_deps = td
, mg_non_boot = case isBootSummary ms of
IsBoot -> mg_non_boot
@@ -176,24 +207,25 @@ extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph
, mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms
}
where
- (gg, _lookup_node) = moduleGraphNodes False (ModuleNode ems : mg_mss)
+ (gg, _lookup_node) = moduleGraphNodes False (ModuleNode deps ms : mg_mss)
td = allReachable gg (mkNodeKey . node_payload)
-extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph
-extendMGInst mg depUnitId = mg
- { mg_mss = InstantiationNode depUnitId : mg_mss mg
+extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph
+extendMGInst mg uid depUnitId = mg
+ { mg_mss = InstantiationNode uid depUnitId : mg_mss mg
}
+extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph
+extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg }
+
extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG' mg = \case
- InstantiationNode depUnitId -> extendMGInst mg depUnitId
- ModuleNode ems -> extendMG mg ems
-
-mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph
-mkModuleGraph = foldr (flip extendMG) emptyMG
+ InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId
+ ModuleNode deps ms -> extendMG mg deps ms
+ LinkNode deps uid -> extendMGLink mg uid deps
-mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph
-mkModuleGraph' = foldr (flip extendMG') emptyMG
+mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
+mkModuleGraph = foldr (flip extendMG') emptyMG
-- | This function filters out all the instantiation nodes from each SCC of a
-- topological sort. Use this with care, as the resulting "strongly connected components"
@@ -202,8 +234,9 @@ mkModuleGraph' = foldr (flip extendMG') emptyMG
filterToposortToModules
:: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
- InstantiationNode _ -> Nothing
- ModuleNode (ExtendedModSummary node _) -> Just node
+ InstantiationNode _ _ -> Nothing
+ LinkNode{} -> Nothing
+ ModuleNode _deps node -> Just node
where
-- This higher order function is somewhat bogus,
-- as the definition of "strongly connected component"
@@ -217,9 +250,17 @@ filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case
as -> Just $ CyclicSCC as
showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
-showModMsg _ _ (InstantiationNode indef_unit) =
+showModMsg dflags _ (LinkNode {}) =
+ let staticLink = case ghcLink dflags of
+ LinkStaticLib -> True
+ _ -> False
+
+ platform = targetPlatform dflags
+ exe_file = exeFileName platform staticLink (outputFile_ dflags)
+ in text exe_file
+showModMsg _ _ (InstantiationNode _uid indef_unit) =
ppr $ instUnitInstanceOf indef_unit
-showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) =
+showModMsg dflags recomp (ModuleNode _ mod_summary) =
if gopt Opt_HideSourcePaths dflags
then text mod_str
else hsep $
@@ -244,7 +285,6 @@ showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) =
-
type SummaryNode = Node Int ModuleGraphNode
summaryNodeKey :: SummaryNode -> Int
@@ -261,22 +301,23 @@ summaryNodeSummary = node_payload
-- .hs, by introducing a cycle. Additionally, it ensures that we will always
-- process the .hs-boot before the .hs, and so the HomePackageTable will always
-- have the most up to date information.
-unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]
-unfilteredEdges drop_hs_boot_nodes = \case
- InstantiationNode iuid ->
- NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)
- ModuleNode (ExtendedModSummary ms bds) ->
- [ NodeKey_Unit inst_unit | inst_unit <- bds ] ++
- (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++
- [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot
+nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]
+nodeDependencies drop_hs_boot_nodes = \case
+ LinkNode deps _uid -> deps
+ InstantiationNode uid iuid ->
+ NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid) <$> uniqDSetToList (instUnitHoles iuid)
+ ModuleNode deps ms ->
+ [ NodeKey_Module $ (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (ms_unitid ms))
| not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile
- ] ++
- (NodeKey_Module . flip GWIB NotBoot . unLoc <$> ms_home_imps ms)
+ ] ++ map drop_hs_boot deps
where
-- Drop hs-boot nodes by using HsSrcFile as the key
hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
| otherwise = IsBoot
+ drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid))
+ drop_hs_boot x = x
+
moduleGraphNodes :: Bool -> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes drop_hs_boot_nodes summaries =
@@ -299,39 +340,30 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
-- We use integers as the keys for the SCC algorithm
nodes :: [SummaryNode]
- nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s
+ nodes = [ DigraphNode s key $ out_edge_keys $ nodeDependencies drop_hs_boot_nodes s
| (s, key) <- numbered_summaries
-- Drop the hi-boot ones if told to do so
, case s of
- InstantiationNode _ -> True
- ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes
+ InstantiationNode {} -> True
+ LinkNode {} -> True
+ ModuleNode _ ms -> not $ isBootSummary ms == IsBoot && drop_hs_boot_nodes
]
out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = mapMaybe lookup_key
-- If we want keep_hi_boot_nodes, then we do lookup_key with
-- IsBoot; else False
-
-type ModNodeKey = ModuleNameWithIsBoot
-
-data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
- deriving (Eq, Ord)
-
-instance Outputable NodeKey where
- ppr nk = pprNodeKey nk
-
newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
deriving (Functor, Traversable, Foldable)
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
- InstantiationNode x -> NodeKey_Unit x
- ModuleNode x -> NodeKey_Module $ ms_mnwib (emsModSummary x)
+ InstantiationNode _ iu -> NodeKey_Unit iu
+ ModuleNode _ x -> NodeKey_Module $ msKey x
+ LinkNode _ uid -> NodeKey_Link uid
-msKey :: ModSummary -> ModuleNameWithIsBoot
-msKey = ms_mnwib
+msKey :: ModSummary -> ModNodeKeyWithUid
+msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms)
-pprNodeKey :: NodeKey -> SDoc
-pprNodeKey (NodeKey_Unit iu) = ppr iu
-pprNodeKey (NodeKey_Module mk) = ppr mk
+type ModNodeKey = ModuleNameWithIsBoot
diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs
index 0f29c5a477..3fd972632f 100644
--- a/compiler/GHC/Unit/Module/ModSummary.hs
+++ b/compiler/GHC/Unit/Module/ModSummary.hs
@@ -4,9 +4,7 @@
-- | A ModSummary is a node in the compilation manager's dependency graph
-- (ModuleGraph)
module GHC.Unit.Module.ModSummary
- ( ExtendedModSummary (..)
- , extendModSummaryNoDeps
- , ModSummary (..)
+ ( ModSummary (..)
, ms_unitid
, ms_installed_mod
, ms_mod_name
@@ -20,6 +18,7 @@ module GHC.Unit.Module.ModSummary
, msHsFilePath
, msObjFilePath
, msDynObjFilePath
+ , msDeps
, isBootSummary
, findTarget
)
@@ -47,21 +46,6 @@ import GHC.Utils.Outputable
import Data.Time
--- | Enrichment of 'ModSummary' with backpack dependencies
-data ExtendedModSummary = ExtendedModSummary
- { emsModSummary :: {-# UNPACK #-} !ModSummary
- , emsInstantiatedUnits :: [InstantiatedUnit]
- -- ^ Extra backpack deps
- -- NB: This is sometimes left empty in situations where the instantiated units
- -- would not be used. See call sites of 'extendModSummaryNoDeps'.
- }
-
-instance Outputable ExtendedModSummary where
- ppr = \case
- ExtendedModSummary ms bds -> ppr ms <+> ppr bds
-
-extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary
-extendModSummaryNoDeps ms = ExtendedModSummary ms []
-- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph
-- are one of:
@@ -127,22 +111,23 @@ ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)
-- say, each of these module names could be a home import if an appropriately
-- named file existed. (This is in contrast to package qualified imports, which
-- are guaranteed not to be home imports.)
-home_imps :: [(PkgQual, Located ModuleName)] -> [Located ModuleName]
-home_imps imps = fmap snd (filter (maybe_home . fst) imps)
+home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)]
+home_imps imps = filter (maybe_home . fst) imps
where maybe_home NoPkgQual = True
maybe_home (ThisPkg _) = True
maybe_home (OtherPkg _) = False
-- | Like 'ms_home_imps', but for SOURCE imports.
-ms_home_srcimps :: ModSummary -> [Located ModuleName]
-ms_home_srcimps = home_imps . ms_srcimps
+ms_home_srcimps :: ModSummary -> ([Located ModuleName])
+-- [] here because source imports can only refer to the current package.
+ms_home_srcimps = map snd . home_imps . ms_srcimps
-- | All of the (possibly) home module imports from a
-- 'ModSummary'; that is to say, each of these module names
-- could be a home import if an appropriately named file
-- existed. (This is in contrast to package qualified
-- imports, which are guaranteed not to be home imports.)
-ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)])
ms_home_imps = home_imps . ms_imps
-- The ModLocation contains both the original source filename and the
@@ -169,12 +154,25 @@ isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot
ms_mnwib :: ModSummary -> ModuleNameWithIsBoot
ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms)
+-- | Returns the dependencies of the ModSummary s.
+msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))])
+msDeps s =
+ [ (NoPkgQual, d)
+ | m <- ms_home_srcimps s
+ , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }
+ ]
+ ]
+ ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot }))
+ | (pkg, m) <- ms_imps s
+ ]
+
instance Outputable ModSummary where
ppr ms
= sep [text "ModSummary {",
nest 3 (sep [text "ms_hs_hash = " <> text (show (ms_hs_hash ms)),
text "ms_mod =" <+> ppr (ms_mod ms)
<> text (hscSourceString (ms_hsc_src ms)) <> comma,
+ text "unit =" <+> ppr (ms_unitid ms),
text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),
text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
char '}'
diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 859b99f1a1..8644848310 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -346,10 +346,11 @@ data UnitConfig = UnitConfig
, unitConfigFlagsIgnored :: [IgnorePackageFlag] -- ^ Ignored units
, unitConfigFlagsTrusted :: [TrustFlag] -- ^ Trusted units
, unitConfigFlagsPlugins :: [PackageFlag] -- ^ Plugins exposed units
+ , unitConfigHomeUnits :: Set.Set UnitId
}
-initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig
-initUnitConfig dflags cached_dbs =
+initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig
+initUnitConfig dflags cached_dbs home_units =
let !hu_id = homeUnitId_ dflags
!hu_instanceof = homeUnitInstanceOf_ dflags
!hu_instantiations = homeUnitInstantiations_ dflags
@@ -383,19 +384,27 @@ initUnitConfig dflags cached_dbs =
, unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags
, unitConfigDBCache = cached_dbs
- , unitConfigFlagsDB = packageDBFlags dflags
+ , unitConfigFlagsDB = map (offsetPackageDb (workingDirectory dflags)) $ packageDBFlags dflags
, unitConfigFlagsExposed = packageFlags dflags
, unitConfigFlagsIgnored = ignorePackageFlags dflags
, unitConfigFlagsTrusted = trustFlags dflags
, unitConfigFlagsPlugins = pluginPackageFlags dflags
+ , unitConfigHomeUnits = home_units
}
+ where
+ offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
+ offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p))
+ offsetPackageDb _ p = p
+
+
-- | Map from 'ModuleName' to a set of module providers (i.e. a 'Module' and
-- its 'ModuleOrigin').
--
-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one
-- origin for a given 'Module'
+
type ModuleNameProvidersMap =
Map ModuleName (Map Module ModuleOrigin)
@@ -435,6 +444,8 @@ data UnitState = UnitState {
-- We'll use this to generate version macros.
explicitUnits :: [Unit],
+ homeUnitDepends :: [UnitId],
+
-- | This is a full map from 'ModuleName' to all modules which may possibly
-- be providing it. These providers may be hidden (but we'll still want
-- to report them in error messages), or it may be an ambiguous import.
@@ -468,6 +479,7 @@ emptyUnitState = UnitState {
unwireMap = Map.empty,
preloadUnits = [],
explicitUnits = [],
+ homeUnitDepends = [],
moduleNameProvidersMap = Map.empty,
pluginModuleNameProvidersMap = Map.empty,
requirementContext = Map.empty,
@@ -480,6 +492,9 @@ data UnitDatabase unit = UnitDatabase
, unitDatabaseUnits :: [GenUnitInfo unit]
}
+instance Outputable u => Outputable (UnitDatabase u) where
+ ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
+
type UnitInfoMap = Map UnitId UnitInfo
-- | Find the unit we know about with the given unit, if any
@@ -598,14 +613,14 @@ listUnitInfo state = Map.elems (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs = do
+initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs)
+ $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1159,7 +1174,7 @@ upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap
upd_wired_in_uid :: WiringMap -> Unit -> Unit
upd_wired_in_uid wiredInMap u = case u of
- HoleUnit -> HoleUnit
+ HoleUnit -> HoleUnit
RealUnit (Definite uid) -> RealUnit (Definite (upd_wired_in wiredInMap uid))
VirtUnit indef_uid ->
VirtUnit $ mkInstantiatedUnit
@@ -1491,10 +1506,13 @@ mkUnitState logger cfg = do
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
- let other_flags = reverse (unitConfigFlagsExposed cfg)
+ let raw_other_flags = reverse (unitConfigFlagsExposed cfg)
+ (hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags
debugTraceMsg logger 2 $
text "package flags" <+> ppr other_flags
+ let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
+
-- Merge databases together, without checking validity
(pkg_map1, prec_map) <- mergeDatabases logger dbs
@@ -1654,6 +1672,7 @@ mkUnitState logger cfg = do
let !state = UnitState
{ preloadUnits = dep_preload
, explicitUnits = explicit_pkgs
+ , homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
, moduleNameProvidersMap = mod_map
@@ -1666,6 +1685,19 @@ mkUnitState logger cfg = do
}
return (state, raw_dbs)
+selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
+selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True
+selectHptFlag _ _ = False
+
+selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId
+selectHomeUnits home_units flags = foldl' go Set.empty flags
+ where
+ go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId
+ go cur (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = Set.insert (toUnitId uid) cur
+ -- MP: This does not yet support thinning/renaming
+ go cur _ = cur
+
+
-- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
-- that it was recorded as in the package database.
unwireUnit :: UnitState -> Unit -> Unit
diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs
index fd35e70957..51a09f72e1 100644
--- a/compiler/GHC/Unit/Types.hs
+++ b/compiler/GHC/Unit/Types.hs
@@ -14,8 +14,10 @@ module GHC.Unit.Types
GenModule (..)
, Module
, InstalledModule
+ , HomeUnitModule
, InstantiatedModule
, mkModule
+ , moduleUnitId
, pprModule
, pprInstantiatedModule
, moduleFreeHoles
@@ -117,10 +119,17 @@ data GenModule unit = Module
-- | A Module is a pair of a 'Unit' and a 'ModuleName'.
type Module = GenModule Unit
+moduleUnitId :: Module -> UnitId
+moduleUnitId = toUnitId . moduleUnit
+
-- | A 'InstalledModule' is a 'Module' whose unit is identified with an
-- 'UnitId'.
type InstalledModule = GenModule UnitId
+-- | A 'HomeUnitModule' is like an 'InstalledModule' but we expect to find it in
+-- one of the home units rather than the package database.
+type HomeUnitModule = GenModule UnitId
+
-- | An `InstantiatedModule` is a 'Module' whose unit is identified with an `InstantiatedUnit`.
type InstantiatedModule = GenModule InstantiatedUnit