diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2021-07-20 11:49:22 +0200 |
|---|---|---|
| committer | Matthew Pickering <matthewtpickering@gmail.com> | 2021-12-28 09:47:53 +0000 |
| commit | fd42ab5fa1df847a6b595dfe4b63d9c7eecbf400 (patch) | |
| tree | 3bd7add640ee4e1340de079a16a05fd34548925f | |
| parent | 3219610e3ba6cb6a5cd1f4e32e2b4befea5bd384 (diff) | |
| download | haskell-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>
334 files changed, 3996 insertions, 1536 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index d70ca74d25..770cdf62b8 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -31,7 +31,10 @@ module GHC ( DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, - getSessionDynFlags, setSessionDynFlags, + getSessionDynFlags, + setTopSessionDynFlags, + setSessionDynFlags, + setUnitDynFlags, getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, interpretPackageEnv, @@ -425,6 +428,7 @@ import System.IO.Error ( isDoesNotExistError ) import System.Environment ( getEnv, getProgName ) import System.Directory import Data.List (isPrefixOf) +import qualified Data.Set as S -- %************************************************************************ @@ -632,22 +636,84 @@ checkBrokenTablesNextToCode' logger dflags -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). - --- | Updates both the interactive and program DynFlags in a Session. --- This also reads the package database (unless it has already been --- read), and prepares the compilers knowledge about packages. It can --- be called again to load new packages: just add new package flags to --- (packageFlags dflags). -setSessionDynFlags :: GhcMonad m => DynFlags -> m () +-- This is a compatability function which sets dynflags for the top session +-- as well as the unit. +setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do + hsc_env <- getSession + logger <- getLogger + dflags <- checkNewDynFlags logger dflags0 + let all_uids = hsc_all_home_unit_ids hsc_env + case S.toList all_uids of + [uid] -> do + setUnitDynFlagsNoCheck uid dflags + modifySession (hscSetActiveUnitId (homeUnitId_ dflags)) + dflags' <- getDynFlags + setTopSessionDynFlags dflags' + [] -> panic "nohue" + _ -> panic "setSessionDynFlags can only be used with a single home unit" + + +setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlags uid dflags0 = do logger <- getLogger dflags1 <- checkNewDynFlags logger dflags0 + setUnitDynFlagsNoCheck uid dflags1 + +setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m () +setUnitDynFlagsNoCheck uid dflags1 = do + logger <- getLogger hsc_env <- getSession - let old_unit_env = hsc_unit_env hsc_env - let cached_unit_dbs = ue_unit_dbs old_unit_env - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs - dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) + let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants + + let upd hue = + hue + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_home_unit = Just home_unit + } + + let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) + + let dflags = updated_dflags + + let unit_env0 = unit_env + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + } + + -- if necessary, change the key for the currently active unit + -- as the dynflags might have been changed + + -- This function is called on every --make invocation because at the start of + -- the session there is one fake unit called main which is immediately replaced + -- after the DynFlags are parsed. + let !unit_env1 = + if homeUnitId_ dflags /= uid + then + ue_renameUnitId + uid + (homeUnitId_ dflags) + unit_env0 + else unit_env0 + + modifySession $ \h -> h{ hsc_unit_env = unit_env1 + } + + invalidateModSummaryCache + + + + +setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () +setTopSessionDynFlags dflags = do + hsc_env <- getSession + logger <- getLogger -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -685,22 +751,10 @@ setSessionDynFlags dflags0 = do return Nothing #endif - let unit_env = UnitEnv - { ue_platform = targetPlatform dflags - , ue_namever = ghcNameVersion dflags - , ue_home_unit = Just home_unit - , ue_hpt = ue_hpt old_unit_env - , ue_eps = ue_eps old_unit_env - , ue_units = unit_state - , ue_unit_dbs = Just dbs - } - modifySession $ \h -> hscSetFlags dflags $ + modifySession $ \h -> hscSetFlags dflags h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags } , hsc_interp = hsc_interp h <|> interp - -- we only update the interpreter if there wasn't - -- already one set up - , hsc_unit_env = unit_env } invalidateModSummaryCache @@ -722,22 +776,35 @@ setProgramDynFlags_ invalidate_needed dflags = do let changed = packageFlagsChanged dflags_prev dflags0 if changed then do - old_unit_env <- hsc_unit_env <$> getSession - let cached_unit_dbs = ue_unit_dbs old_unit_env - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs - - dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants + -- additionally, set checked dflags so we don't lose fixes + old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession + + home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph let unit_env = UnitEnv - { ue_platform = targetPlatform dflags1 - , ue_namever = ghcNameVersion dflags1 - , ue_home_unit = Just home_unit - , ue_hpt = ue_hpt old_unit_env - , ue_eps = ue_eps old_unit_env - , ue_units = unit_state - , ue_unit_dbs = Just dbs + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit old_unit_env + , ue_eps = ue_eps old_unit_env } - modifySession $ \h -> hscSetFlags dflags1 $ h{ hsc_unit_env = unit_env } + modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) when invalidate_needed $ invalidateModSummaryCache @@ -828,7 +895,8 @@ parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], parseTargetFiles dflags0 fileish_args = let normal_fileish_paths = map normalise_hyp fileish_args - (srcs, objs) = partition_args normal_fileish_paths [] [] + (srcs, raw_objs) = partition_args normal_fileish_paths [] [] + objs = map (augmentByWorkingDirectory dflags0) raw_objs dflags1 = dflags0 { ldInputs = map (FileOption "") objs ++ ldInputs dflags0 } @@ -1025,7 +1093,7 @@ unitIdOrHomeUnit mUnitId = do workingDirectoryChanged :: GhcMonad m => m () workingDirectoryChanged = do hsc_env <- getSession - liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env) + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) -- %************************************************************************ @@ -1389,7 +1457,7 @@ availsToGlobalRdrEnv mod_name avails getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = - case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of + case lookupHugByModule mdl (hsc_HUG hsc_env) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi @@ -1643,25 +1711,22 @@ findModule mod_name maybe_pkg = do findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> 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 + let mhome_unit = hsc_home_unit_maybe hsc_env + let dflags = hsc_dflags hsc_env case pkgqual of - ThisPkg _ -> do - home <- lookupLoadedHomeModule mod_name + ThisPkg uid -> do + home <- lookupLoadedHomeModule uid mod_name case home of Just m -> return m Nothing -> liftIO $ do - res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual + res <- findImportedModule hsc_env mod_name pkgqual case res of Found loc m | notHomeModuleMaybe mhome_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err _ -> liftIO $ do - res <- findImportedModule fc fopts units mhome_unit mod_name pkgqual + res <- findImportedModule hsc_env mod_name pkgqual case res of Found _ m -> return m err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err @@ -1693,7 +1758,7 @@ lookupModule mod_name maybe_pkg = do lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do - home <- lookupLoadedHomeModule mod_name + home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name case home of Just m -> return m Nothing -> liftIO $ do @@ -1707,9 +1772,9 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) -lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) mod_name of +lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module) +lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> + case lookupHug (hsc_HUG hsc_env) uid mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 51315c8b75..487fd7971c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -485,6 +485,7 @@ Library GHC.Linker.Loader GHC.Linker.MacOS GHC.Linker.Static + GHC.Linker.Static.Utils GHC.Linker.Types GHC.Linker.Unit GHC.Linker.Windows diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst index 2184946571..994dc66d74 100644 --- a/docs/users_guide/using.rst +++ b/docs/users_guide/using.rst @@ -740,6 +740,131 @@ search path (see :ref:`search-path`). number of processors. Note that compilation of a module may not begin until its dependencies have been built. +.. _multi-home-units: + +Multiple Home Units +~~~~~~~~~~~~~~~~~~~ + +The compiler also has support for building multiple units in a single compiler +invocation. In modern projects it is common to work on multiple interdependent +packages at once, using the support for multiple home units you can load all +these local packages into one ghc session and quickly get feedback about how +changes affect other dependent packages. + +In order to specify multiple units, the `-unit @⟨filename⟩`:ghc-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. + +.. code-block:: none + + ghc -unit @unitA -unit @unitB + +where the ``unitA`` response file contains the normal arguments that you would +pass to ``--make`` mode. + +.. code-block:: none + + -this-unit-id a-0.1.0.0 + -i + -isrc + A1 + A2 + ... + +Then when the compiler starts in ``--make`` mode it will compile both units ``a`` and ``b``. + +There is also very basic support for multple home units in GHCi, at the moment you can start +a GHCi session with multiple units but only the `:reload`:ghci-cmd: is supported. + +.. ghc-flag:: -unit @⟨filename⟩ + :shortdesc: Specify the options to build a specific unit. + :type: dynamic + :category: misc + + This option is passed multiple times to inform the compiler about all the + home units which it will compile. The options for each unit are supplied + in a response file which contains a newline separated list of normal arguments. + +There are a few extra flags which have been introduced to make working with multiple +units easier. + +.. ghc-flag:: -working-dir ⟨dir⟩ + :shortdesc: Specify the directory a unit is expected to be compiled in. + :type: dynamic + :category: + + 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`:ghc-flag: and `-I⟨dir⟩`:ghc-flag: flags. + + + This option can also be queried by the ``getPackageRoot`` Template Haskell + function. It is intended to be used with helper functions such as ``makeRelativeToProject`` + which make relative filepaths relative to the compilation directory rather than + the directory which contains the .cabal file. + +.. ghc-flag:: -this-package-name ⟨unit-id⟩ + :shortdesc: The name of the package which this module would be part of when installed. + :type: dynamic + :category: + + This flag papers over the awkward interaction of the `PackageImports`:extension: + 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. + +.. ghc-flag:: -hidden-module ⟨module name⟩ + :shortdesc: A module which should not be visible outside its unit. + :type: dynamic + :category: + + 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. + +.. ghc-flag:: -reexported-module ⟨module name⟩ + :shortdesc: A module which should be reexported from this unit. + :type: dynamic + :category: + + 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. + + + +The home unit closure requirement +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +There is one very important closure property which you must ensure when using +multiple home units. + + Any external unit must not depend on any home unit. + +This closure property is checked by the compiler but it's up to the tool invoking +GHC to ensure that the supplied list of home units obey this invariant. + +For example, if we have three units, ``p``, ``q`` and ``r``, where ``p`` depends on ``q`` and +``q`` depends on ``r``, then the closure property states that if we load ``p`` and ``r`` as +home units then we must also load ``q``, because ``q`` depends on the home unit ``r`` and we need +``q`` because ``p`` depends on it. + + .. _eval-mode: Expression evaluation mode diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 137619100b..a51d30232c 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -51,7 +51,6 @@ import GHC.Driver.Session as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) import GHC.Driver.Monad ( modifySession ) -import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Config.Diagnostic import qualified GHC @@ -162,6 +161,7 @@ import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) import GHCi.Leak +import qualified GHC.Unit.Module.Graph as GHC ----------------------------------------------------------------------------- @@ -197,7 +197,7 @@ ghciCommands = map mkCmd [ ("back", keepGoing backCmd, noCompletion), ("browse", keepGoing' (browseCmd False), completeModule), ("browse!", keepGoing' (browseCmd True), completeModule), - ("cd", keepGoing' changeDirectory, completeFilename), + ("cd", keepGoingMulti' changeDirectory, completeFilename), ("check", keepGoing' checkModule, completeHomeModule), ("continue", keepGoing continueCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), @@ -213,14 +213,14 @@ ghciCommands = map mkCmd [ ("etags", keepGoing createETagsFileCmd, completeFilename), ("force", keepGoing forceCmd, completeExpression), ("forward", keepGoing forwardCmd, noCompletion), - ("help", keepGoing help, noCompletion), - ("history", keepGoing historyCmd, noCompletion), - ("info", keepGoing' (info False), completeIdentifier), - ("info!", keepGoing' (info True), completeIdentifier), + ("help", keepGoingMulti help, noCompletion), + ("history", keepGoingMulti historyCmd, noCompletion), + ("info", keepGoingMulti' (info False), completeIdentifier), + ("info!", keepGoingMulti' (info True), completeIdentifier), ("issafe", keepGoing' isSafeCmd, completeModule), ("ignore", keepGoing ignoreCmd, noCompletion), - ("kind", keepGoing' (kindOfType False), completeIdentifier), - ("kind!", keepGoing' (kindOfType True), completeIdentifier), + ("kind", keepGoingMulti' (kindOfType False), completeIdentifier), + ("kind!", keepGoingMulti' (kindOfType True), completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), @@ -228,19 +228,19 @@ ghciCommands = map mkCmd [ ("main", keepGoing runMain, completeFilename), ("print", keepGoing printCmd, completeExpression), ("quit", quit, noCompletion), - ("reload", keepGoing' reloadModule, noCompletion), - ("reload!", keepGoing' reloadModuleDefer, noCompletion), + ("reload", keepGoingMulti' reloadModule, noCompletion), + ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion), ("run", keepGoing runRun, completeFilename), ("script", keepGoing' scriptCmd, completeFilename), ("set", keepGoing setCmd, completeSetOptions), ("seti", keepGoing setiCmd, completeSeti), - ("show", keepGoing showCmd, completeShowOptions), + ("show", keepGoingMulti' showCmd, completeShowOptions), ("showi", keepGoing showiCmd, completeShowiOptions), ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), - ("type", keepGoing' typeOfExpr, completeExpression), + ("type", keepGoingMulti' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), ("unadd", keepGoingPaths unAddModule, completeFilename), ("undef", keepGoing undefineMacro, completeMacro), @@ -294,15 +294,31 @@ flagWordBreakChars = " \t\n" keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) keepGoing a str = keepGoing' (lift . a) str -keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool -keepGoing' a str = a str >> return False +keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi Bool) +keepGoingMulti a str = keepGoingMulti' (lift . a) str + +keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m Bool +keepGoing' a str = do + in_multi <- inMultiMode + if in_multi + then + liftIO $ hPutStrLn stderr "Command is not supported (yet) in multi-mode" + else + a str + return False + +-- For commands which are actually support in multi-mode, initially just :reload +keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m Bool +keepGoingMulti' a str = a str >> return False + +inMultiMode :: GhciMonad m => m Bool +inMultiMode = multiMode <$> getGHCiState keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool) keepGoingPaths a str = do case toArgsNoLoc str of - Left err -> liftIO $ hPutStrLn stderr err - Right args -> a args - return False + Left err -> liftIO $ hPutStrLn stderr err >> return False + Right args -> keepGoing' a args defShortHelpText :: String defShortHelpText = "use :? for help.\n" @@ -456,9 +472,12 @@ default_prompt_cont = generatePromptFunctionFromString "ghci| " default_args :: [String] default_args = [] -interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String] +interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> Ghc () interactiveUI config srcs maybe_exprs = do + -- This is a HACK to make sure dynflags are not overwritten when setting + -- options. When GHCi is made properly multi component it should be removed. + modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env) -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -517,6 +536,8 @@ interactiveUI config srcs maybe_exprs = do default_editor <- liftIO $ findEditor eval_wrapper <- mkEvalWrapper default_progname default_args let prelude_import = simpleImportDecl preludeModuleName + hsc_env <- GHC.getSession + let in_multi = length (hsc_all_home_unit_ids hsc_env) > 1 startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = default_progname, args = default_args, @@ -526,6 +547,7 @@ interactiveUI config srcs maybe_exprs = do stop = default_stop, editor = default_editor, options = [], + multiMode = in_multi, localConfig = SourceLocalConfig, -- We initialize line number as 0, not 1, because we use -- current line number while reporting errors which is @@ -620,7 +642,7 @@ withGhcConfig right left = do right dir _ -> left -runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () +runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do dflags <- getDynFlags let @@ -703,13 +725,12 @@ runGHCi paths maybe_exprs = do -- Importantly, if $PWD/.ghci was ignored due to configuration, -- explicitly specifying it does cause it to be processed. - -- Perform a :load for files given on the GHCi command line + -- Perform a :reload for files given on the GHCi command line + -- The appropiate targets will already be set -- When in -e mode, if the load fails then we want to stop -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ - -- TODO: this is a hack. - runInputTWithPrefs defaultPrefs defaultSettings $ loadModule paths when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) @@ -1628,7 +1649,7 @@ changeDirectory dir = do liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed." -- delete targets and all eventually defined breakpoints (#1620) clearAllTargets - setContextAfterLoad False [] + setContextAfterLoad False Nothing GHC.workingDirectoryChanged dir' <- expandPath dir liftIO $ setCurrentDirectory dir' @@ -1683,7 +1704,7 @@ editFile str = -- Our strategy is to pick the first module that failed to load, -- or otherwise the first target. -- --- XXX: Can we figure out what happened if the depndecy analysis fails +-- XXX: Can we figure out what happened if the dependency analysis fails -- (e.g., because the porgrammeer mistyped the name of a module)? -- XXX: Can we figure out the location of an error to pass to the editor? -- XXX: if we could figure out the list of errors that occurred during the @@ -1691,11 +1712,12 @@ editFile str = -- of those. chooseEditFile :: GHC.GhcMonad m => m String chooseEditFile = - do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x + do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x + hasFailed _ = return False graph <- GHC.getModuleGraph failed_graph <- - GHC.mkModuleGraph . fmap extendModSummaryNoDeps <$> filterM hasFailed (GHC.mgModSummaries graph) + GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries' graph) let order g = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True g Nothing pick xs = case xs of @@ -1968,24 +1990,24 @@ wrapDeferTypeErrors load = (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags) (\_ -> load) -loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag +loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule fs = do (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs) either (liftIO . Exception.throwIO) return result -- | @:load@ command loadModule_ :: GhciMonad m => [FilePath] -> m () -loadModule_ fs = void $ loadModule (zip fs (repeat Nothing)) +loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing)) loadModuleDefer :: GhciMonad m => [FilePath] -> m () loadModuleDefer = wrapDeferTypeErrors . loadModule_ -loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag +loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule' files = do - let (filenames, phases) = unzip files + let (filenames, uids, phases) = unzip3 files exp_filenames <- mapM expandPath filenames - let files' = zip exp_filenames phases - targets <- mapM (\(file, phase) -> GHC.guessTarget file Nothing phase) files' + let files' = zip3 exp_filenames uids phases + targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files' -- NOTE: we used to do the dependency anal first, so that if it -- fails we didn't throw away the current set of modules. This would @@ -2034,13 +2056,9 @@ addModule files = do checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool checkTargetModule m = do hsc_env <- GHC.getSession - let fc = hsc_FC hsc_env let home_unit = hsc_home_unit hsc_env - let units = hsc_units hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags result <- liftIO $ - Finder.findImportedModule fc fopts units (Just home_unit) m (ThisPkg (homeUnitId home_unit)) + Finder.findImportedModule hsc_env m (ThisPkg (homeUnitId home_unit)) case result of Found _ _ -> return True _ -> (liftIO $ putStrLn $ @@ -2063,10 +2081,13 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () -reloadModule m = void $ doLoadAndCollectInfo True loadTargets +reloadModule m = do + session <- GHC.getSession + let home_unit = homeUnitId (hsc_home_unit session) + void $ doLoadAndCollectInfo True (loadTargets home_unit) where - loadTargets | null m = LoadAllTargets - | otherwise = LoadUpTo (GHC.mkModuleName m) + loadTargets hu | null m = LoadAllTargets + | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -2130,34 +2151,40 @@ afterLoad ok retain_context = do discardTickArrays loaded_mods <- getLoadedModules modulesLoadedMsg ok loaded_mods - setContextAfterLoad retain_context loaded_mods + graph <- GHC.getModuleGraph + setContextAfterLoad retain_context (Just graph) -setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m () -setContextAfterLoad keep_ctxt [] = do +setContextAfterLoad :: GhciMonad m => Bool -> Maybe GHC.ModuleGraph -> m () +setContextAfterLoad keep_ctxt Nothing = do setContextKeepingPackageModules keep_ctxt [] -setContextAfterLoad keep_ctxt ms = do +setContextAfterLoad keep_ctxt (Just graph) = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets - case [ m | Just m <- map (findTarget ms) targets ] of + loaded_graph <- filterM is_loaded $ GHC.mgModSummaries' graph + case [ m | Just m <- map (findTarget loaded_graph) targets ] of [] -> - let graph = GHC.mkModuleGraph $ extendModSummaryNoDeps <$> ms - graph' = flattenSCCs $ filterToposortToModules $ - GHC.topSortModuleGraph True graph Nothing - in load_this (last graph') + let graph' = flattenSCCs $ filterToposortToModules $ + GHC.topSortModuleGraph True (GHC.mkModuleGraph loaded_graph) Nothing + in case graph' of + [] -> setContextKeepingPackageModules keep_ctxt [] + xs -> load_this (last xs) (m:_) -> load_this m where + is_loaded (GHC.ModuleNode _ ms) = GHC.isLoaded (ms_mod_name ms) + is_loaded _ = return False + findTarget mds t - = case filter (`matches` t) mds of + = case mapMaybe (`matches` t) mds of [] -> Nothing (m:_) -> Just m - summary `matches` Target { targetId = TargetModule m } - = GHC.ms_mod_name summary == m - summary `matches` Target { targetId = TargetFile f _ } - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' - _ `matches` _ - = False + (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetModule m } + = if GHC.ms_mod_name summary == m then Just summary else Nothing + (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ } + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = + if f == f' then Just summary else Nothing + _ `matches` _ = Nothing load_this summary | m <- GHC.ms_mod summary = do is_interp <- GHC.moduleIsInterpreted m @@ -3114,7 +3141,7 @@ newDynFlags interactive_only minus_opts = do let units = preloadUnits (hsc_units hsc_env) liftIO $ Loader.loadPackages interp hsc_env units -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False [] + setContextAfterLoad False Nothing -- and copy the package flags to the interactive DynFlags idflags <- GHC.getInteractiveDynFlags GHC.setInteractiveDynFlags diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 72a44530e6..157b9e8950 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -90,6 +90,7 @@ data GHCiState = GHCiState prompt_cont :: PromptFunction, editor :: String, stop :: String, + multiMode :: Bool, localConfig :: LocalConfigBehaviour, options :: [GHCiOption], line_number :: !Int, -- ^ input line diff --git a/ghc/Main.hs b/ghc/Main.hs index d00ae72990..69ec3a8593 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -29,7 +29,6 @@ import GHC.Driver.Pipeline ( oneShot, compileFile ) import GHC.Driver.MakeFile ( doMkDependHS ) import GHC.Driver.Backpack ( doBackpack ) import GHC.Driver.Plugins -import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Diagnostic @@ -44,10 +43,13 @@ import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings import GHC.Runtime.Loader ( loadFrontendPlugin ) import GHC.Unit.Env +import GHC.Unit (UnitId, homeUnitDepends) +import GHC.Unit.Home.ModInfo (emptyHomePackageTable) import GHC.Unit.Module ( ModuleName, mkModuleName ) import GHC.Unit.Module.ModIface import GHC.Unit.State ( pprUnits, pprUnitsSimple ) import GHC.Unit.Finder ( findImportedModule, FindResult(..) ) +import qualified GHC.Unit.State as State import GHC.Unit.Types ( IsBootInterface(..) ) import GHC.Types.Basic ( failed ) @@ -76,6 +78,7 @@ import GHC.Iface.Load import GHC.Iface.Recomp.Binary ( fingerprintBinMem ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) +import System.FilePath -- Standard Haskell libraries import System.IO @@ -85,10 +88,15 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except (throwE, runExceptT) import Data.Char -import Data.List ( isPrefixOf, partition, intercalate ) +import Data.List ( isPrefixOf, partition, intercalate, (\\) ) import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Maybe import Prelude +import GHC.ResponseFile (expandResponse) +import Data.Bifunctor +import GHC.Data.Graph.Directed +import qualified Data.List.NonEmpty as NE ----------------------------------------------------------------------------- -- ToDo: @@ -119,7 +127,7 @@ main = do let argv2 = map (mkGeneralLocated "on the commandline") argv1 -- 2. Parse the "mode" flags (--make, --interactive etc.) - (mode, argv3, flagWarnings) <- parseModeFlags argv2 + (mode, units, argv3, flagWarnings) <- parseModeFlags argv2 -- If all we want to do is something like showing the version number -- then do it now, before we start a GHC session etc. This makes @@ -151,11 +159,11 @@ main = do ShowGhciUsage -> showGhciUsage dflags PrintWithDynFlags f -> putStrLn (f dflags) Right postLoadMode -> - main' postLoadMode dflags argv3 flagWarnings + main' postLoadMode units dflags argv3 flagWarnings -main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn] +main' :: PostLoadMode -> [String] -> DynFlags -> [Located String] -> [Warn] -> Ghc () -main' postLoadMode dflags0 args flagWarnings = do +main' postLoadMode units dflags0 args flagWarnings = do let args' = case postLoadMode of DoRun -> takeWhile (\arg -> unLoc arg /= "--") args _ -> args @@ -252,7 +260,7 @@ main' postLoadMode dflags0 args flagWarnings = do liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6) ---------------- Final sanity checking ----------- - liftIO $ checkOptions postLoadMode dflags6 srcs objs + liftIO $ checkOptions postLoadMode dflags6 srcs objs units ---------------- Do the business ----------- handleSourceError (\e -> do @@ -264,12 +272,12 @@ main' postLoadMode dflags0 args flagWarnings = do (hsc_units hsc_env) (hsc_NC hsc_env) f - DoMake -> doMake srcs + DoMake -> doMake units srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs) - DoInteractive -> ghciUI srcs Nothing - DoEval exprs -> ghciUI srcs $ Just $ reverse exprs - DoRun -> doRun srcs args + DoInteractive -> ghciUI units srcs Nothing + DoEval exprs -> ghciUI units srcs $ Just $ reverse exprs + DoRun -> doRun units srcs args DoAbiHash -> abiHash (map fst srcs) ShowPackages -> liftIO $ showUnits hsc_env DoFrontend f -> doFrontend f srcs @@ -277,20 +285,30 @@ main' postLoadMode dflags0 args flagWarnings = do liftIO $ dumpFinalStats logger -doRun :: [(FilePath, Maybe Phase)] -> [Located String] -> Ghc () -doRun srcs args = do +doRun :: [String] -> [(FilePath, Maybe Phase)] -> [Located String] -> Ghc () +doRun units srcs args = do dflags <- getDynFlags let mainFun = fromMaybe "main" (mainFunIs dflags) - ghciUI srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"]) + ghciUI units srcs (Just ["System.Environment.withArgs " ++ show args' ++ " (Control.Monad.void " ++ mainFun ++ ")"]) where args' = drop 1 $ dropWhile (/= "--") $ map unLoc args -ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () +ghciUI :: [String] -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #if !defined(HAVE_INTERNAL_INTERPRETER) -ghciUI _ _ = +ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use") #else -ghciUI srcs maybe_expr = interactiveUI defaultGhciSettings srcs maybe_expr +ghciUI units srcs maybe_expr = do + hs_srcs <- case NE.nonEmpty units of + Just ne_units -> do + initMulti ne_units + Nothing -> do + case srcs of + [] -> return [] + _ -> do + s <- initMake srcs + return $ map (uncurry (,Nothing,)) s + interactiveUI defaultGhciSettings hs_srcs maybe_expr #endif @@ -300,9 +318,9 @@ ghciUI srcs maybe_expr = interactiveUI defaultGhciSettings srcs maybe_expr -- | Ensure sanity of options. -- -- Throws 'UsageError' or 'CmdLineError' if not. -checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO () +checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO () -- Final sanity checking before kicking off a compilation (pipeline). -checkOptions mode dflags srcs objs = do +checkOptions mode dflags srcs objs units = do -- Complain about any unknown flags let unknown_opts = [ f | (f@('-':_), _) <- srcs ] when (notNull unknown_opts) (unknownFlagsErr unknown_opts) @@ -341,8 +359,8 @@ checkOptions mode dflags srcs objs = do -- Check that there are some input files -- (except in the interactive case) - if null srcs && (null objs || not_linking) && needsInputsMode mode - then throwGhcException (UsageError "no input files") + if null srcs && (null objs || not_linking) && needsInputsMode mode && null units + then throwGhcException (UsageError "no input files" ) else do case mode of @@ -538,13 +556,13 @@ isCompManagerMode _ = False -- Parsing the mode flag parseModeFlags :: [Located String] - -> IO (Mode, + -> IO (Mode, [String], [Located String], [Warn]) parseModeFlags args = do - let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) = + let ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) = runCmdLine (processArgs mode_flags args) - (Nothing, [], []) + (Nothing, [], [], []) mode = case mModeFlag of Nothing -> doMakeMode Just (m, _) -> m @@ -553,9 +571,9 @@ parseModeFlags args = do unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $ map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2 - return (mode, flags' ++ leftover, warns) + return (mode, units, flags' ++ leftover, warns) -type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String]) +type ModeM = CmdLineP (Maybe (Mode, String), [String], [String], [Located String]) -- mode flags sometimes give rise to new DynFlags (eg. -C, see below) -- so we collect the new ones and return them. @@ -612,6 +630,7 @@ mode_flags = , defFlag "S" (PassFlag (setMode (stopBeforeMode StopAs))) , defFlag "-run" (PassFlag (setMode doRunMode)) , defFlag "-make" (PassFlag (setMode doMakeMode)) + , defFlag "unit" (SepArg (\s -> addUnit s "-unit")) , defFlag "-backpack" (PassFlag (setMode doBackpackMode)) , defFlag "-interactive" (PassFlag (setMode doInteractiveMode)) , defFlag "-abi-hash" (PassFlag (setMode doAbiHashMode)) @@ -619,9 +638,14 @@ mode_flags = , defFlag "-frontend" (SepArg (\s -> setMode (doFrontendMode s) "-frontend")) ] +addUnit :: String -> String -> EwM ModeM () +addUnit unit_str _arg = liftEwM $ do + (mModeFlag, units, errs, flags') <- getCmdLineState + putCmdLineState (mModeFlag, unit_str:units, errs, flags') + setMode :: Mode -> String -> EwM ModeM () setMode newMode newFlag = liftEwM $ do - (mModeFlag, errs, flags') <- getCmdLineState + (mModeFlag, units, errs, flags') <- getCmdLineState let (modeFlag', errs') = case mModeFlag of Nothing -> ((newMode, newFlag), errs) @@ -670,7 +694,7 @@ setMode newMode newFlag = liftEwM $ do -- Otherwise, complain _ -> let err = flagMismatchErr oldFlag newFlag in ((oldMode, oldFlag), err : errs) - putCmdLineState (Just modeFlag', errs', flags') + putCmdLineState (Just modeFlag', units, errs', flags') where isDominantFlag f = isShowGhcUsageMode f || isShowGhciUsageMode f || isShowVersionMode f || @@ -682,15 +706,31 @@ flagMismatchErr oldFlag newFlag addFlag :: String -> String -> EwM ModeM () addFlag s flag = liftEwM $ do - (m, e, flags') <- getCmdLineState - putCmdLineState (m, e, mkGeneralLocated loc s : flags') + (m, units, e, flags') <- getCmdLineState + putCmdLineState (m, units, e, mkGeneralLocated loc s : flags') where loc = "addFlag by " ++ flag ++ " on the commandline" -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: [(String,Maybe Phase)] -> Ghc () -doMake srcs = do +doMake :: [String] -> [(String, Maybe Phase)] -> Ghc () +doMake units targets = do + hs_srcs <- case NE.nonEmpty units of + Just ne_units -> do + initMulti ne_units + Nothing -> do + s <- initMake targets + return $ map (uncurry (,Nothing,)) s + case hs_srcs of + [] -> return () + _ -> do + targets' <- mapM (\(src, uid, phase) -> GHC.guessTarget src uid phase) hs_srcs + GHC.setTargets targets' + ok_flag <- GHC.load LoadAllTargets + when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) + +initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)] +initMake srcs = do let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs hsc_env <- GHC.getSession @@ -700,7 +740,7 @@ doMake srcs = do -- This means that "ghc Foo.o Bar.o -o baz" links the program as -- we expect. if (null hs_srcs) - then liftIO (oneShot hsc_env NoStop srcs) + then liftIO (oneShot hsc_env NoStop srcs) >> return [] else do o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x) @@ -709,14 +749,186 @@ doMake srcs = do let dflags' = dflags { ldInputs = map (FileOption "") o_files ++ ldInputs dflags } _ <- GHC.setSessionDynFlags dflags' + return hs_srcs + +-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. +removeRTS :: [String] -> [String] +removeRTS ("+RTS" : xs) = + case dropWhile (/= "-RTS") xs of + [] -> [] + (_ : ys) -> removeRTS ys +removeRTS (y:ys) = y : removeRTS ys +removeRTS [] = [] + +initMulti :: NE.NonEmpty String -> Ghc ([(String, Maybe UnitId, Maybe Phase)]) +initMulti unitArgsFiles = do + hsc_env <- GHC.getSession + let logger = hsc_logger hsc_env + initial_dflags <- GHC.getSessionDynFlags + + dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do + when (verbosity initial_dflags > 2) (liftIO $ print f) + args <- liftIO $ expandResponse [f] + (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine initial_dflags (map (mkGeneralLocated f) (removeRTS args)) + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ handleFlagWarnings logger (initDiagOpts dflags2) warns + + let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args) + dflags4 = offsetDynFlags dflags3 + + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + -- This is dubious as the whole unit environment won't be set-up correctly, but + -- that doesn't matter for what we use it for (linking and oneShot) + let dubious_hsc_env = hscSetFlags dflags4 hsc_env + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, []) + else do + + o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x) + non_hs_srcs + let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags4 } + + liftIO $ checkOptions DoMake dflags5 srcs objs [] + + pure (dflags5, hs_srcs) + + let + unitDflags = NE.map fst dynFlagsAndSrcs + srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs + (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs)) + + checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) + + let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags + home_units = unitEnv_keys initial_home_graph + + home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + hue_flags = homeUnitEnv_dflags homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + pure $ HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = emptyHomePackageTable + , homeUnitEnv_home_unit = Just home_unit + } + + checkUnitCycles initial_dflags home_unit_graph + + let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph + unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + + GHC.setSession final_hsc_env + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then do + liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode." + liftIO $ exitWith (ExitFailure 1) + else do + +{- + o_files <- liftIO $ mapMaybeM + (\(src, uid, mphase) -> + compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase) + ) + (concat non_hs_srcs) + -} + + -- MP: This should probably modify dflags for each unit? + --let dflags' = dflags { ldInputs = map (FileOption "") o_files + -- ++ ldInputs dflags } + return $ concat hs_srcs + +-- | Check that we don't have multiple units with the same UnitId. + +checkUnitCycles :: DynFlags -> UnitEnvGraph HomeUnitEnv -> Ghc () +checkUnitCycles dflags graph = processSCCs sccs + where + mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId + mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + nodes = map mkNode (unitEnv_elts graph) + + sccs = stronglyConnCompFromEdgedVerticesOrd nodes + + processSCCs [] = return () + processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs + processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + + + cycle_err uids = + hang (text "Units form a dependency cycle:") + 2 + (one_err uids) + + one_err uids = vcat $ + (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) + ++ [text "-" <+> ppr final] + where + start = init uids + final = last uids + +checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () +checkDuplicateUnits dflags flags = + unless (null duplicate_ids) + (throwGhcException $ CmdLineError $ showSDoc dflags multi_err) + + where + uids = map (second homeUnitId_) flags + deduplicated_uids = ordNubOn snd uids + duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids) + + duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids + + one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp + + multi_err = + hang (text "Multiple units with the same unit-id:") + 2 + (vcat (map one_err duplicate_flags)) + + +offsetDynFlags :: DynFlags -> DynFlags +offsetDynFlags dflags = + dflags { hiDir = c hiDir + , objectDir = c objectDir + , stubDir = c stubDir + , hieDir = c hieDir + , dumpDir = c dumpDir } + + where + c f = augment_maybe (f dflags) - targets <- mapM (\(src, phase) -> GHC.guessTarget src Nothing phase) hs_srcs - GHC.setTargets targets - ok_flag <- GHC.load LoadAllTargets + augment_maybe Nothing = Nothing + augment_maybe (Just f) = Just (augment f) + augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f + | otherwise = f - when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) - return () +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> (HomeUnitGraph, UnitId) +createUnitEnvFromFlags unitDflags = + let + newInternalUnitEnv dflags = mkHomeUnitEnv dflags emptyHomePackageTable Nothing + unitEnvList = NE.map (\dflags -> (homeUnitId_ dflags, newInternalUnitEnv dflags)) unitDflags + activeUnit = fst $ NE.head unitEnvList + in + (unitEnv_new (Map.fromList (NE.toList (unitEnvList))), activeUnit) -- --------------------------------------------------------------------------- -- Various banners and verbosity output. @@ -873,17 +1085,13 @@ abiHash :: [String] -- ^ List of module names -> Ghc () abiHash strs = do hsc_env <- getSession - 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 + let dflags = hsc_dflags hsc_env liftIO $ do let find_it str = do let modname = mkModuleName str - r <- findImportedModule fc fopts units mhome_unit modname NoPkgQual + r <- findImportedModule hsc_env modname NoPkgQual case r of Found _ m -> return m _error -> throwGhcException $ CmdLineError $ showSDoc dflags $ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index d5f8e84520..6b23f913cb 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -259,6 +259,7 @@ data THMessage a where ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo) ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) + GetPackageRoot :: THMessage (THResult FilePath) AddDependentFile :: FilePath -> THMessage (THResult ()) AddTempFile :: String -> THMessage (THResult FilePath) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) @@ -311,6 +312,7 @@ getTHMessage = do 22 -> THMsg <$> ReifyType <$> get 23 -> THMsg <$> (PutDoc <$> get <*> get) 24 -> THMsg <$> GetDoc <$> get + 25 -> THMsg <$> return GetPackageRoot n -> error ("getTHMessage: unknown message " ++ show n) putTHMessage :: THMessage a -> Put @@ -340,6 +342,7 @@ putTHMessage m = case m of ReifyType a -> putWord8 22 >> put a PutDoc l s -> putWord8 23 >> put l >> put s GetDoc l -> putWord8 24 >> put l + GetPackageRoot -> putWord8 25 data EvalOpts = EvalOpts diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index f2325db1e1..723e966095 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -194,6 +194,7 @@ instance TH.Quasi GHCiQ where qReifyModule m = ghcCmd (ReifyModule m) qReifyConStrictness name = ghcCmd (ReifyConStrictness name) qLocation = fromMaybe noLoc . qsLocation <$> getState + qGetPackageRoot = ghcCmd GetPackageRoot qAddDependentFile file = ghcCmd (AddDependentFile file) qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index fd03edb872..f30bb0ef87 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -31,6 +31,7 @@ module Language.Haskell.TH.Syntax import Data.Data hiding (Fixity(..)) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) +import System.FilePath import GHC.IO.Unsafe ( unsafeDupableInterleaveIO ) import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO (..)) @@ -103,6 +104,7 @@ class (MonadIO m, MonadFail m) => Quasi m where qRunIO :: IO a -> m a qRunIO = liftIO -- ^ Input/output (dangerous) + qGetPackageRoot :: m FilePath qAddDependentFile :: FilePath -> m () @@ -154,6 +156,7 @@ instance Quasi IO where qReifyConStrictness _ = badIO "reifyConStrictness" qLocation = badIO "currentLocation" qRecover _ _ = badIO "recover" -- Maybe we could fix this? + qGetPackageRoot = badIO "getProjectRoot" qAddDependentFile _ = badIO "addDependentFile" qAddTempFile _ = badIO "addTempFile" qAddTopDecls _ = badIO "addTopDecls" @@ -708,6 +711,27 @@ location = Q qLocation runIO :: IO a -> Q a runIO m = Q (qRunIO m) +-- | Get the package root for the current package which is being compiled. +-- This can be set explicitly with the -package-root flag but is normally +-- just the current working directory. +-- +-- The motivation for this flag is to provide a principled means to remove the +-- assumption from splices that they will be executed in the directory where the +-- cabal file resides. Projects such as haskell-language-server can't and don't +-- change directory when compiling files but instead set the -package-root flag +-- appropiately. +getPackageRoot :: Q FilePath +getPackageRoot = Q qGetPackageRoot + +-- | The input is a filepath, which if relative is offset by the package root. +makeRelativeToProject :: FilePath -> Q FilePath +makeRelativeToProject fp | isRelative fp = do + root <- getPackageRoot + return (root </> fp) +makeRelativeToProject fp = return fp + + + -- | Record external files that runIO is using (dependent upon). -- The compiler can then recognize that it should re-compile the Haskell file -- when an external file changes. @@ -858,6 +882,7 @@ instance Quasi Q where qReifyConStrictness = reifyConStrictness qLookupName = lookupName qLocation = location + qGetPackageRoot = getPackageRoot qAddDependentFile = addDependentFile qAddTempFile = addTempFile qAddTopDecls = addTopDecls diff --git a/libraries/template-haskell/template-haskell.cabal.in b/libraries/template-haskell/template-haskell.cabal.in index 963e547a58..097e5bae24 100644 --- a/libraries/template-haskell/template-haskell.cabal.in +++ b/libraries/template-haskell/template-haskell.cabal.in @@ -58,6 +58,7 @@ Library base >= 4.11 && < 4.17, ghc-boot-th == @ProjectVersionMunged@, ghc-prim, + filepath, pretty == 1.1.* ghc-options: -Wall diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index d41fc9b88c..fb2a7010f5 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -1342,46 +1342,53 @@ def ghci_script( name, way, script): # Compile-only tests def compile( name, way, extra_hc_opts ): - return do_compile( name, way, False, None, [], extra_hc_opts ) + return do_compile( name, way, False, None, [], [], extra_hc_opts ) def compile_fail( name, way, extra_hc_opts ): - return do_compile( name, way, True, None, [], extra_hc_opts ) + return do_compile( name, way, True, None, [], [], extra_hc_opts ) def backpack_typecheck( name, way, extra_hc_opts ): - return do_compile( name, way, False, None, [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=True ) + return do_compile( name, way, False, None, [], [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=True ) def backpack_typecheck_fail( name, way, extra_hc_opts ): - return do_compile( name, way, True, None, [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=True ) + return do_compile( name, way, True, None, [], [], "-fno-code -fwrite-interface " + extra_hc_opts, backpack=True ) def backpack_compile( name, way, extra_hc_opts ): - return do_compile( name, way, False, None, [], extra_hc_opts, backpack=True ) + return do_compile( name, way, False, None, [], [], extra_hc_opts, backpack=True ) def backpack_compile_fail( name, way, extra_hc_opts ): - return do_compile( name, way, True, None, [], extra_hc_opts, backpack=True ) + return do_compile( name, way, True, None, [], [], extra_hc_opts, backpack=True ) def backpack_run( name, way, extra_hc_opts ): return compile_and_run__( name, way, None, [], extra_hc_opts, backpack=True ) def multimod_compile( name, way, top_mod, extra_hc_opts ): - return do_compile( name, way, False, top_mod, [], extra_hc_opts ) + return do_compile( name, way, False, top_mod, [], [], extra_hc_opts ) def multimod_compile_fail( name, way, top_mod, extra_hc_opts ): - return do_compile( name, way, True, top_mod, [], extra_hc_opts ) + return do_compile( name, way, True, top_mod, [], [], extra_hc_opts ) def multimod_compile_filter( name, way, top_mod, extra_hc_opts, filter_with, suppress_stdout=True ): - return do_compile( name, way, False, top_mod, [], extra_hc_opts, filter_with=filter_with, suppress_stdout=suppress_stdout ) + return do_compile( name, way, False, top_mod, [], [], extra_hc_opts, filter_with=filter_with, suppress_stdout=suppress_stdout ) + +def multiunit_compile( name, way, units, extra_hc_opts ): + return do_compile( name, way, False, None, [], units, extra_hc_opts ) + +def multiunit_compile_fail( name, way, units, extra_hc_opts ): + return do_compile( name, way, True, None, [], units, extra_hc_opts ) def multi_compile( name, way, top_mod, extra_mods, extra_hc_opts ): - return do_compile( name, way, False, top_mod, extra_mods, extra_hc_opts) + return do_compile( name, way, False, top_mod, extra_mods, [], extra_hc_opts) def multi_compile_fail( name, way, top_mod, extra_mods, extra_hc_opts ): - return do_compile( name, way, True, top_mod, extra_mods, extra_hc_opts) + return do_compile( name, way, True, top_mod, extra_mods, [], extra_hc_opts) def do_compile(name: TestName, way: WayName, should_fail: bool, top_mod: Optional[Path], extra_mods: List[str], + units: List[str], extra_hc_opts: str, **kwargs ) -> PassFail: @@ -1392,7 +1399,7 @@ def do_compile(name: TestName, return result extra_hc_opts = result.hc_opts - result = simple_build(name, way, extra_hc_opts, should_fail, top_mod, False, True, **kwargs) + result = simple_build(name, way, extra_hc_opts, should_fail, top_mod, units, False, True, **kwargs) if badResult(result): return result @@ -1427,7 +1434,7 @@ def compile_cmp_asm(name: TestName, extra_hc_opts: str ) -> PassFail: print('Compile only, extra args = ', extra_hc_opts) - result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, False, False) + result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): return result @@ -1454,7 +1461,7 @@ def compile_grep_asm(name: TestName, extra_hc_opts: str ) -> PassFail: print('Compile only, extra args = ', extra_hc_opts) - result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, False, False) + result = simple_build(name + '.' + ext, way, '-keep-s-files -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): return result @@ -1475,7 +1482,7 @@ def compile_grep_core(name: TestName, extra_hc_opts: str ) -> PassFail: print('Compile only, extra args = ', extra_hc_opts) - result = simple_build(name + '.hs', way, '-ddump-to-file -dsuppress-all -ddump-simpl -O ' + extra_hc_opts, False, None, False, False) + result = simple_build(name + '.hs', way, '-ddump-to-file -dsuppress-all -ddump-simpl -O ' + extra_hc_opts, False, None, [], False, False) if badResult(result): return result @@ -1511,7 +1518,7 @@ def compile_and_run__(name: TestName, if way.startswith('ghci'): # interpreted... return interpreter_run(name, way, extra_hc_opts, top_mod) else: # compiled... - result = simple_build(name, way, extra_hc_opts, False, top_mod, True, True, backpack = backpack) + result = simple_build(name, way, extra_hc_opts, False, top_mod, [], True, True, backpack = backpack) if badResult(result): return result @@ -1621,7 +1628,7 @@ def check_stats(name: TestName, def extras_build( way, extra_mods, extra_hc_opts ): for mod, opts in extra_mods: - result = simple_build(mod, way, opts + ' ' + extra_hc_opts, False, None, False, False) + result = simple_build(mod, way, opts + ' ' + extra_hc_opts, False, None, [], False, False) if not (mod.endswith('.hs') or mod.endswith('.lhs')): extra_hc_opts += ' %s' % Path(mod).with_suffix('.o') if badResult(result): @@ -1634,6 +1641,7 @@ def simple_build(name: Union[TestName, str], extra_hc_opts: str, should_fail: bool, top_mod: Optional[Path], + units: List[str], link: bool, addsuf: bool, backpack: bool = False, @@ -1667,6 +1675,10 @@ def simple_build(name: Union[TestName, str], to_do = to_do + '--backpack ' elif link: to_do = '-o ' + name + elif len(units) > 0: + to_do = '--make' + for u in units: + to_do = to_do + ' -unit @%s' % u else: to_do = '-c' # just compile diff --git a/testsuite/tests/backpack/should_compile/bkp40.bkp b/testsuite/tests/backpack/should_compile/bkp40.bkp index d149d75877..749cfa5f92 100644 --- a/testsuite/tests/backpack/should_compile/bkp40.bkp +++ b/testsuite/tests/backpack/should_compile/bkp40.bkp @@ -36,7 +36,7 @@ unit eqmap where -- Need to insert redundant constraint to make it work... insert :: Eq k => k -> a -> Map k a -> Map k a insert k v (Assoc xs) = Assoc ((k,v):xs) -unit main where +unit top where dependency user[Map=ordmap:Map] (User as User.Ord) dependency user[Map=eqmap:Map] (User as User.Eq) diff --git a/testsuite/tests/backpack/should_compile/bkp40.stderr b/testsuite/tests/backpack/should_compile/bkp40.stderr index f250951578..56216c5f3e 100644 --- a/testsuite/tests/backpack/should_compile/bkp40.stderr +++ b/testsuite/tests/backpack/should_compile/bkp40.stderr @@ -7,8 +7,8 @@ [3 of 4] Processing eqmap Instantiating eqmap [1 of 1] Compiling Map ( eqmap/Map.hs, bkp40.out/eqmap/Map.o ) -[4 of 4] Processing main - Instantiating main +[4 of 4] Processing top + Instantiating top [1 of 2] Including user[Map=ordmap:Map] Instantiating user[Map=ordmap:Map] [1 of 2] Compiling Map[sig] ( user/Map.hsig, bkp40.out/user/user-GzloW2NeDdA2M0V8qzN4g2/Map.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp41.bkp b/testsuite/tests/backpack/should_compile/bkp41.bkp index e8b5b24e35..fae5bc81fc 100644 --- a/testsuite/tests/backpack/should_compile/bkp41.bkp +++ b/testsuite/tests/backpack/should_compile/bkp41.bkp @@ -14,5 +14,5 @@ unit sig where import B app = print T -unit main where +unit top where dependency sig[B=impl:B] diff --git a/testsuite/tests/backpack/should_compile/bkp41.stderr b/testsuite/tests/backpack/should_compile/bkp41.stderr index 766317718c..1ef9343d38 100644 --- a/testsuite/tests/backpack/should_compile/bkp41.stderr +++ b/testsuite/tests/backpack/should_compile/bkp41.stderr @@ -5,8 +5,8 @@ [2 of 3] Processing sig [1 of 2] Compiling B[sig] ( sig/B.hsig, nothing ) [2 of 2] Compiling App ( sig/App.hs, nothing ) -[3 of 3] Processing main - Instantiating main +[3 of 3] Processing top + Instantiating top [1 of 1] Including sig[B=impl:B] Instantiating sig[B=impl:B] [1 of 2] Compiling B[sig] ( sig/B.hsig, bkp41.out/sig/sig-HVnmSw44WZeBfwnUur4wzl/B.o ) diff --git a/testsuite/tests/backpack/should_compile/bkp42.bkp b/testsuite/tests/backpack/should_compile/bkp42.bkp index 59590f9125..9541738852 100644 --- a/testsuite/tests/backpack/should_compile/bkp42.bkp +++ b/testsuite/tests/backpack/should_compile/bkp42.bkp @@ -17,5 +17,5 @@ unit sig where app :: T -> IO () app t = print t -unit main where +unit top where dependency sig[B=impl:C] diff --git a/testsuite/tests/backpack/should_compile/bkp42.stderr b/testsuite/tests/backpack/should_compile/bkp42.stderr index ae2bb75c51..460a098e18 100644 --- a/testsuite/tests/backpack/should_compile/bkp42.stderr +++ b/testsuite/tests/backpack/should_compile/bkp42.stderr @@ -6,8 +6,8 @@ [2 of 3] Processing sig [1 of 2] Compiling B[sig] ( sig/B.hsig, nothing ) [2 of 2] Compiling App ( sig/App.hs, nothing ) -[3 of 3] Processing main - Instantiating main +[3 of 3] Processing top + Instantiating top [1 of 1] Including sig[B=impl:C] Instantiating sig[B=impl:C] [1 of 2] Compiling B[sig] ( sig/B.hsig, bkp42.out/sig/sig-Ko6MwJiRFc509cOdDShPV5/B.o ) diff --git a/testsuite/tests/backpack/should_fail/bkpfail51.stderr b/testsuite/tests/backpack/should_fail/bkpfail51.stderr index c732e0bcbf..9f40ff1d01 100644 --- a/testsuite/tests/backpack/should_fail/bkpfail51.stderr +++ b/testsuite/tests/backpack/should_fail/bkpfail51.stderr @@ -2,7 +2,7 @@ [1 of 2] Compiling H[sig] ( p/H.hsig, nothing ) [2 of 2] Compiling I ( p/I.hs, nothing ) [2 of 2] Processing q -Module imports and instantiations form a cycle: +Module graph contains a cycle: instantiated unit p[H=A] imports module ‘A’ (q/A.hsig) which imports instantiated unit p[H=A] diff --git a/testsuite/tests/cabal/T12485/T12485.stdout b/testsuite/tests/cabal/T12485/T12485.stdout index aefbf389b1..5d24c873ce 100644 --- a/testsuite/tests/cabal/T12485/T12485.stdout +++ b/testsuite/tests/cabal/T12485/T12485.stdout @@ -1,6 +1,6 @@ Reading package info from "a.pkg" ... done. Reading package info from "b.pkg" ... done. -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main [Objects changed] diff --git a/testsuite/tests/cabal/cabal08/cabal08.stdout b/testsuite/tests/cabal/cabal08/cabal08.stdout index 06a164b150..200f53e482 100644 --- a/testsuite/tests/cabal/cabal08/cabal08.stdout +++ b/testsuite/tests/cabal/cabal08/cabal08.stdout @@ -1,12 +1,12 @@ -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main p2 -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main [Objects changed] p1 -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main [Objects changed] p2 -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main [Objects changed] p1 diff --git a/testsuite/tests/cmm/should_compile/T16930.stdout b/testsuite/tests/cmm/should_compile/T16930.stdout index bc33620682..ebbb14dcd5 100644 --- a/testsuite/tests/cmm/should_compile/T16930.stdout +++ b/testsuite/tests/cmm/should_compile/T16930.stdout @@ -1,6 +1,6 @@ testing -ddump-cmm-verbose for T16930 ... -[1 of 1] Compiling Main ( T16930.hs, T16930.o ) -Linking T16930 ... +[1 of 2] Compiling Main ( T16930.hs, T16930.o ) +[2 of 2] Linking T16930 T16930.dump-cmm-caf T16930.dump-cmm-cfg T16930.dump-cmm-cps diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index c4d629069c..05fb3712ae 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 276 Language.Haskell.Syntax module dependencies +Found 277 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -121,6 +121,7 @@ GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax GHC.Iface.Type +GHC.Linker.Static.Utils GHC.Linker.Types GHC.Parser.Annotation GHC.Parser.Errors.Basic diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 457e42da8e..11b74ade5f 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 282 GHC.Parser module dependencies +Found 283 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -122,6 +122,7 @@ GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax GHC.Iface.Type +GHC.Linker.Static.Utils GHC.Linker.Types GHC.Parser GHC.Parser.Annotation diff --git a/testsuite/tests/deriving/should_fail/T14365.stderr b/testsuite/tests/deriving/should_fail/T14365.stderr index f8f106fea8..a166953cf5 100644 --- a/testsuite/tests/deriving/should_fail/T14365.stderr +++ b/testsuite/tests/deriving/should_fail/T14365.stderr @@ -11,3 +11,4 @@ T14365B.hs-boot:7:1: error: Cannot derive instances in hs-boot files Write an instance declaration instead • In the stand-alone deriving instance for ‘Foldable Foo’ +[3 of 3] Compiling T14365B ( T14365B.hs, T14365B.o ) diff --git a/testsuite/tests/driver/MultiRootsErr.hs b/testsuite/tests/driver/MultiRootsErr.hs new file mode 100644 index 0000000000..858ea3b9bb --- /dev/null +++ b/testsuite/tests/driver/MultiRootsErr.hs @@ -0,0 +1 @@ +module MultiRootsErr where diff --git a/testsuite/tests/driver/MultiRootsErr.stderr b/testsuite/tests/driver/MultiRootsErr.stderr new file mode 100644 index 0000000000..c4b11bfe84 --- /dev/null +++ b/testsuite/tests/driver/MultiRootsErr.stderr @@ -0,0 +1,4 @@ + +<no location info>: error: + module ‘main:MultiRootsErr’ is defined in multiple files: MultiRootsErr.hs + MultiRootsErr.hs diff --git a/testsuite/tests/driver/T12983/T12983.stdout b/testsuite/tests/driver/T12983/T12983.stdout index 321e702d27..3e34b745fc 100644 --- a/testsuite/tests/driver/T12983/T12983.stdout +++ b/testsuite/tests/driver/T12983/T12983.stdout @@ -1,18 +1,18 @@ Preparing everyting with --make ... -[1 of 3] Compiling Hospital -[2 of 3] Compiling Types -[3 of 3] Compiling Main -Linking src/MetaHandler ... +[1 of 4] Compiling Hospital +[2 of 4] Compiling Types +[3 of 4] Compiling Main +[4 of 4] Linking src/MetaHandler Done with preparations with --make Building with --make -[1 of 4] Compiling ShortText -[2 of 4] Compiling Hospital [Source file changed] -[4 of 4] Compiling Main [Hospital[TH] changed] -Linking src/MetaHandler ... +[1 of 5] Compiling ShortText +[2 of 5] Compiling Hospital [Source file changed] +[4 of 5] Compiling Main [Hospital[TH] changed] +[5 of 5] Linking src/MetaHandler [Objects changed] Preparing everything ... src/Hospital.hs diff --git a/testsuite/tests/driver/T13914/T13914.stdout b/testsuite/tests/driver/T13914/T13914.stdout index d443ed47b9..6453a0011c 100644 --- a/testsuite/tests/driver/T13914/T13914.stdout +++ b/testsuite/tests/driver/T13914/T13914.stdout @@ -1,16 +1,16 @@ Without -fignore-asserts -[1 of 1] Compiling Main ( main.hs, main.o ) -Linking main ... +[1 of 2] Compiling Main ( main.hs, main.o ) +[2 of 2] Linking main main: Assertion failed CallStack (from HasCallStack): assert, called at main.hs:3:8 in main:Main With -fignore-asserts -[1 of 1] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] -Linking main ... +[1 of 2] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] +[2 of 2] Linking main [Objects changed] OK Without -fignore-asserts -[1 of 1] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] -Linking main ... +[1 of 2] Compiling Main ( main.hs, main.o ) [Optimisation flags changed] +[2 of 2] Linking main [Objects changed] main: Assertion failed CallStack (from HasCallStack): assert, called at main.hs:3:8 in main:Main diff --git a/testsuite/tests/driver/T16608/T16608_1.stdout b/testsuite/tests/driver/T16608/T16608_1.stdout index f925d67b8c..ce5a336950 100644 --- a/testsuite/tests/driver/T16608/T16608_1.stdout +++ b/testsuite/tests/driver/T16608/T16608_1.stdout @@ -1,7 +1,7 @@ -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) -[2 of 2] Compiling Main ( T16608_1.hs, T16608_1.o ) -Linking T16608_1 ... +[1 of 3] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[2 of 3] Compiling Main ( T16608_1.hs, T16608_1.o ) +[3 of 3] Linking T16608_1 41 -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] -Linking T16608_1 ... +[1 of 3] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] +[3 of 3] Linking T16608_1 [Objects changed] 42 diff --git a/testsuite/tests/driver/T16608/T16608_2.stdout b/testsuite/tests/driver/T16608/T16608_2.stdout index af2de7e698..8935c0bb3f 100644 --- a/testsuite/tests/driver/T16608/T16608_2.stdout +++ b/testsuite/tests/driver/T16608/T16608_2.stdout @@ -1,7 +1,7 @@ -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) -[2 of 2] Compiling Main ( T16608_2.hs, T16608_2.o ) -Linking T16608_2 ... +[1 of 3] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) +[2 of 3] Compiling Main ( T16608_2.hs, T16608_2.o ) +[3 of 3] Linking T16608_2 41 -[1 of 2] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] -Linking T16608_2 ... +[1 of 3] Compiling MyInteger ( MyInteger.hs, MyInteger.o ) [Source file changed] +[3 of 3] Linking T16608_2 [Objects changed] 42 diff --git a/testsuite/tests/driver/T17481.stdout b/testsuite/tests/driver/T17481.stdout index 885dac3986..204b0ee2af 100644 --- a/testsuite/tests/driver/T17481.stdout +++ b/testsuite/tests/driver/T17481.stdout @@ -1,14 +1,14 @@ Main.hs is now: main = putStrLn "Hello from A" Compiling and running Main.hs: -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main Hello from A Main.hs is now: main = putStrLn "Hello from B" Compiling and running Main.hs: -[1 of 1] Compiling Main ( Main.hs, Main.o ) [Source file changed] -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) [Source file changed] +[2 of 2] Linking Main [Objects changed] Hello from B Touching Main.hs Compiling and running Main.hs: diff --git a/testsuite/tests/driver/T17586/T17586.stdout b/testsuite/tests/driver/T17586/T17586.stdout index d0bb37090e..e541917636 100644 --- a/testsuite/tests/driver/T17586/T17586.stdout +++ b/testsuite/tests/driver/T17586/T17586.stdout @@ -1,6 +1,6 @@ -[1 of 1] Compiling Main ( T17586.hs, T17586.o ) -Linking T17586 ... +[1 of 2] Compiling Main ( T17586.hs, T17586.o ) +[2 of 2] Linking T17586 hello world -[1 of 1] Compiling Main ( T17586.hs, T17586.o ) [Flags changed] -Linking T17586 ... +[1 of 2] Compiling Main ( T17586.hs, T17586.o ) [Flags changed] +[2 of 2] Linking T17586 [Objects changed] hello world diff --git a/testsuite/tests/driver/T20300/T20300.stderr b/testsuite/tests/driver/T20300/T20300.stderr index 1a93d8d7ba..37b55fd9c1 100644 --- a/testsuite/tests/driver/T20300/T20300.stderr +++ b/testsuite/tests/driver/T20300/T20300.stderr @@ -1,4 +1,4 @@ [1 of 4] Compiling T[boot] ( T.hs-boot, nothing ) [2 of 4] Compiling S ( S.hs, S.o, S.dyn_o ) -[3 of 4] Compiling T ( T.hs, T.o, T.dyn_o ) +[3 of 4] Compiling T ( T.hs, nothing ) [4 of 4] Compiling Top ( Top.hs, nothing ) diff --git a/testsuite/tests/driver/T20316.stdout b/testsuite/tests/driver/T20316.stdout index 280a3c80e7..f46d4f0715 100644 --- a/testsuite/tests/driver/T20316.stdout +++ b/testsuite/tests/driver/T20316.stdout @@ -1,4 +1,4 @@ -[1 of 1] Compiling Main ( T20316.hs, nothing ) +[1 of 2] Compiling Main ( T20316.hs, nothing ) *** non-module.dump-timings *** initializing unit database: Chasing dependencies: diff --git a/testsuite/tests/driver/T20459.stderr b/testsuite/tests/driver/T20459.stderr index 63ae634930..f37ef0be3e 100644 --- a/testsuite/tests/driver/T20459.stderr +++ b/testsuite/tests/driver/T20459.stderr @@ -1,2 +1,2 @@ -Module imports form a cycle: +Module graph contains a cycle: module ‘T20459A’ (./T20459A.hs) imports itself diff --git a/testsuite/tests/driver/T437/T437.stdout b/testsuite/tests/driver/T437/T437.stdout index 2057b5df86..3dd0b5cc3b 100644 --- a/testsuite/tests/driver/T437/T437.stdout +++ b/testsuite/tests/driver/T437/T437.stdout @@ -1,10 +1,10 @@ -[1 of 2] Compiling Test2 ( Test2.hs, Test2.o ) -[2 of 2] Compiling Test ( Test.hs, Test.o ) -Linking Test ... -[1 of 1] Compiling Test2 ( Test2.hs, Test2.o ) [Flags changed] -Linking Test2 ... +[1 of 3] Compiling Test2 ( Test2.hs, Test2.o ) +[2 of 3] Compiling Test ( Test.hs, Test.o ) +[3 of 3] Linking Test +[1 of 2] Compiling Test2 ( Test2.hs, Test2.o ) [Flags changed] +[2 of 2] Linking Test2 "Test2.doit" "Test2.main" -[1 of 1] Compiling Test2 ( Test2.hs, Test2.o ) [Flags changed] -Linking Test2 ... +[1 of 2] Compiling Test2 ( Test2.hs, Test2.o ) [Flags changed] +[2 of 2] Linking Test2 [Objects changed] "Test2.doit" diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T index 4af15b7640..907002fcf7 100644 --- a/testsuite/tests/driver/all.T +++ b/testsuite/tests/driver/all.T @@ -302,3 +302,4 @@ test('T20459', normal, multimod_compile_fail, test('T20200loop', extra_files(['T20200loop']), multimod_compile, ['Datatypes', '-iT20200loop -O -v0']) test('T20316', normal, makefile_test, []) +test('MultiRootsErr', normal, multimod_compile_fail, ['MultiRootsErr', 'MultiRootsErr']) diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeA.stdout b/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeA.stdout index d80c899cb1..76ad05bb37 100644 --- a/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeA.stdout +++ b/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeA.stdout @@ -1,6 +1,6 @@ -[1 of 3] Compiling A ( A.hs, A.o, A.dyn_o ) -[2 of 3] Compiling B ( B.hs, B.o, B.dyn_o ) -[3 of 3] Compiling Main ( C.hs, C.o, C.dyn_o ) -Linking C ... -[2 of 3] Compiling B ( B.hs, B.o, B.dyn_o ) [Missing dynamic interface file] -Linking C ... +[1 of 4] Compiling A ( A.hs, A.o, A.dyn_o ) +[2 of 4] Compiling B ( B.hs, B.o, B.dyn_o ) +[3 of 4] Compiling Main ( C.hs, C.o, C.dyn_o ) +[4 of 4] Linking C +[2 of 4] Compiling B ( B.hs, B.o, B.dyn_o ) [Missing dynamic interface file] +[4 of 4] Linking C [Objects changed] diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeB.stdout b/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeB.stdout index 56caf28582..1e2de97295 100644 --- a/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeB.stdout +++ b/testsuite/tests/driver/dynamicToo/dynamicToo001/dynamicToo001MakeB.stdout @@ -1,3 +1,3 @@ -[2 of 3] Compiling B ( B.hs, B.o, B.dyn_o ) [Mismatched dynamic interface file] -[3 of 3] Compiling Main ( C.hs, C.o, C.dyn_o ) -Linking C ... +[2 of 4] Compiling B ( B.hs, B.o, B.dyn_o ) [Mismatched dynamic interface file] +[3 of 4] Compiling Main ( C.hs, C.o, C.dyn_o ) +[4 of 4] Linking C diff --git a/testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout b/testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout index 5c33cb2e7a..243efe5829 100644 --- a/testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout +++ b/testsuite/tests/driver/dynamicToo/dynamicToo006/dynamicToo006.stdout @@ -1,2 +1,2 @@ -[1 of 1] Compiling Main ( Main.hs, Main.o, Main.dyn_o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o, Main.dyn_o ) +[2 of 2] Linking Main diff --git a/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.hs b/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.hs new file mode 100644 index 0000000000..9163054cab --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -working-dir=a #-} +{-# OPTIONS_GHC -hidden-module=A #-} +{-# OPTIONS_GHC -reexported-module=A #-} +{-# OPTIONS_GHC -this-package-name=pp #-} +module Main where diff --git a/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.stderr b/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.stderr new file mode 100644 index 0000000000..70de257142 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/MHU_OptionsGHC.stderr @@ -0,0 +1,12 @@ + +MHU_OptionsGHC.hs:1:17: error: + Unknown flag in {-# OPTIONS_GHC #-} pragma: -working-dir=a + +MHU_OptionsGHC.hs:2:17: error: + Unknown flag in {-# OPTIONS_GHC #-} pragma: -hidden-module=A + +MHU_OptionsGHC.hs:3:17: error: + Unknown flag in {-# OPTIONS_GHC #-} pragma: -reexported-module=A + +MHU_OptionsGHC.hs:4:17: error: + Unknown flag in {-# OPTIONS_GHC #-} pragma: -this-package-name=pp diff --git a/testsuite/tests/driver/multipleHomeUnits/Makefile b/testsuite/tests/driver/multipleHomeUnits/Makefile new file mode 100644 index 0000000000..d244bc6834 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/Makefile @@ -0,0 +1,33 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +EXECTUABLE_C = c/C$(exeext) +EXECTUABLE_D = d/D$(exeext) +CLEAN_FILES = a/A.o a/A.hi a/A.hie b/B.o b/B.hi b/B.hie c/C.o c/C.hi c/C.hie d/C.o d/C.hi d/C.hie $(EXECTUABLE_C) $(EXECTUABLE_D) + +clean: + $(RM) $(CLEAN_FILES) + +multipleHomeUnits_callstack: clean + '$(TEST_HC)' $(TEST_HC_OPTS) -unit @unitCallstack -v0 + ! ./callstack/Main + +multipleHomeUnits002: clean + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitC -unit @unitD + ./$(EXECTUABLE_C) + ./$(EXECTUABLE_D) + +multipleHomeUnits003: clean + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitA -unit @unitB -unit @unitC -unit @unitD + ./$(EXECTUABLE_C) + ./$(EXECTUABLE_D) + +multipleHomeUnits004_recomp: clean + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitB -unit @unitE + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitB -unit @unitE + +multipleHomeUnitsModuleVisibility: clean + ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -unit @unitMV -unit @unitMV-import + + diff --git a/testsuite/tests/driver/multipleHomeUnits/a/A.hs b/testsuite/tests/driver/multipleHomeUnits/a/A.hs new file mode 100644 index 0000000000..883fd3f17c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/a/A.hs @@ -0,0 +1,3 @@ +module A where + +foo = () diff --git a/testsuite/tests/driver/multipleHomeUnits/all.T b/testsuite/tests/driver/multipleHomeUnits/all.T new file mode 100644 index 0000000000..c2bbf0f368 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/all.T @@ -0,0 +1,57 @@ +test('multipleHomeUnits_single1', [extra_files([ 'a/', 'unitA'])], multiunit_compile, [['unitA'], '-fhide-source-paths']) +test('multipleHomeUnits_single2', [extra_files([ 'b/', 'unitB'])], multiunit_compile, [['unitB'], '-fhide-source-paths']) +test('multipleHomeUnits_single3', [extra_files([ 'c/', 'unitC'])], multiunit_compile, [['unitC'], '-fhide-source-paths']) +test('multipleHomeUnits_single4', [extra_files([ 'd/', 'unitD'])], multiunit_compile, [['unitD'], '-fhide-source-paths']) +test('multipleHomeUnits_single5', [extra_files([ 'th/', 'unitTH'])], multiunit_compile, [['unitTH'], '-fhide-source-paths']) +test('multipleHomeUnits_cpp', [extra_files([ 'cpp-includes/', 'unitCPPIncludes'])], multiunit_compile, [['unitCPPIncludes'], '-fhide-source-paths']) +test('multipleHomeUnits_cfile', [extra_files([ 'c-file/', 'unitCFile'])], multiunit_compile, [['unitCFile'], '-fhide-source-paths']) +test('multipleHomeUnits_callstack', [extra_files([ 'callstack/', 'unitCallstack'])], makefile_test, []) + +test('multipleHomeUnits_cpp2', [extra_files([ 'cpp-includes/', 'cpp-import/', 'unitCPPImport', 'unitCPPIncludes'])], multiunit_compile, [['unitCPPImport', 'unitCPPIncludes'], '-fhide-source-paths']) + +test('multiGHCi', [extra_files(['a/', 'b/', 'unitA', 'unitB', 'multiGHCi.script']) + , extra_run_opts('-unit @unitA -unit @unitB')], ghci_script, ['multiGHCi.script']) + +test('multipleHomeUnits001', + [ extra_files( + [ 'a/', 'b/' + , 'unitA', 'unitB']) + ], multiunit_compile, [['unitA', 'unitB'], '-fhide-source-paths']) + +test('multipleHomeUnits002', + [ extra_files( + [ 'c/', 'd/' + , 'unitC', 'unitD']) + ], makefile_test, []) + +test('multipleHomeUnits003', + [ extra_files( + [ 'a/', 'b/', 'c/', 'd/' + , 'unitA', 'unitB', 'unitC', 'unitD']) + ], makefile_test, []) + +test('multipleHomeUnits004', + [ extra_files( + [ 'b/', 'e/' + , 'unitB', 'unitE']) + ], multiunit_compile, [['unitB', 'unitE'], '-fhide-source-paths']) + +test('multipleHomeUnits004_recomp', + [ extra_files( + [ 'b/', 'e/' + , 'unitB', 'unitE']) + ], makefile_test, []) + +test('multipleHomeUnitsModuleVisibility', + [ extra_files( + [ 'module-visibility/', 'module-visibility-import/' + , 'unitMV', 'unitMV-import']) + ], makefile_test, []) + +test('multipleHomeUnitsPackageImports', + [ extra_files( + [ 'b/', 'b2/', 'package-imports/' + , 'unitB', 'unitB2', 'unitPI']) + ], multiunit_compile, [['unitB', 'unitB2', 'unitPI'], '-fhide-source-paths']) + +test('MHU_OptionsGHC', normal, compile_fail, ['']) diff --git a/testsuite/tests/driver/multipleHomeUnits/b/B.hs b/testsuite/tests/driver/multipleHomeUnits/b/B.hs new file mode 100644 index 0000000000..1bf85fa974 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/b/B.hs @@ -0,0 +1,8 @@ +module B where + +foo = () + +b = foo + +data B = B deriving Show + diff --git a/testsuite/tests/driver/multipleHomeUnits/b2/B.hs b/testsuite/tests/driver/multipleHomeUnits/b2/B.hs new file mode 100644 index 0000000000..1bf85fa974 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/b2/B.hs @@ -0,0 +1,8 @@ +module B where + +foo = () + +b = foo + +data B = B deriving Show + diff --git a/testsuite/tests/driver/multipleHomeUnits/c-file/C.hs b/testsuite/tests/driver/multipleHomeUnits/c-file/C.hs new file mode 100644 index 0000000000..5ced57fc56 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/c-file/C.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE CPP #-} +#include "header1.h" +module C where + +foo = A + diff --git a/testsuite/tests/driver/multipleHomeUnits/c-file/c.c b/testsuite/tests/driver/multipleHomeUnits/c-file/c.c new file mode 100644 index 0000000000..e220cb91da --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/c-file/c.c @@ -0,0 +1,5 @@ +#include "header2.h" +int foo() { + return(B); +} + diff --git a/testsuite/tests/driver/multipleHomeUnits/c-file/include/header1.h b/testsuite/tests/driver/multipleHomeUnits/c-file/include/header1.h new file mode 100644 index 0000000000..ab2a05dbbf --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/c-file/include/header1.h @@ -0,0 +1 @@ +#define A 1 diff --git a/testsuite/tests/driver/multipleHomeUnits/c-file/include/header2.h b/testsuite/tests/driver/multipleHomeUnits/c-file/include/header2.h new file mode 100644 index 0000000000..edd392bc2a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/c-file/include/header2.h @@ -0,0 +1 @@ +#define B 2 diff --git a/testsuite/tests/driver/multipleHomeUnits/c/C.hs b/testsuite/tests/driver/multipleHomeUnits/c/C.hs new file mode 100644 index 0000000000..b9fdcc8ab7 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/c/C.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "unit C compiled successfully" diff --git a/testsuite/tests/driver/multipleHomeUnits/callstack/Main.hs b/testsuite/tests/driver/multipleHomeUnits/callstack/Main.hs new file mode 100644 index 0000000000..7117e65aaa --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/callstack/Main.hs @@ -0,0 +1,4 @@ +module Main where + +-- Callstack should not mention the subdirectory +main = error "test" diff --git a/testsuite/tests/driver/multipleHomeUnits/cpp-import/M.hs b/testsuite/tests/driver/multipleHomeUnits/cpp-import/M.hs new file mode 100644 index 0000000000..aabfc85f90 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/cpp-import/M.hs @@ -0,0 +1,3 @@ +module M where + +import CPPIncludes_Down diff --git a/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes.hs b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes.hs new file mode 100644 index 0000000000..0e8539f738 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +#include "header1.h" +module CPPIncludes where + +-- This module is only discovered by downsweep and hits a different code path +-- to the path which gets mod summaries for the targets +import CPPIncludes_Down + +foo = A + +qux = B diff --git a/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes_Down.hs b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes_Down.hs new file mode 100644 index 0000000000..91c232d0c6 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/CPPIncludes_Down.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} +#include "header1.h" +module CPPIncludes_Down where + +goo = A + +gux = B diff --git a/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header1.h b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header1.h new file mode 100644 index 0000000000..ab2a05dbbf --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header1.h @@ -0,0 +1 @@ +#define A 1 diff --git a/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header2.h b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header2.h new file mode 100644 index 0000000000..edd392bc2a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/cpp-includes/include/header2.h @@ -0,0 +1 @@ +#define B 2 diff --git a/testsuite/tests/driver/multipleHomeUnits/d/C.hs b/testsuite/tests/driver/multipleHomeUnits/d/C.hs new file mode 100644 index 0000000000..04171f50ab --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/d/C.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "unit D compiled successfully" diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/Makefile b/testsuite/tests/driver/multipleHomeUnits/different-db/Makefile new file mode 100644 index 0000000000..c12f6cab34 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/Makefile @@ -0,0 +1,38 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=../Setup -v0 + +different-db: clean + $(MAKE) -s --no-print-directory clean + '$(GHC_PKG)' init tmp.d + '$(GHC_PKG)' init tmp1.d + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + # Put p into tmp.d + cd p && $(SETUP) clean + cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd p && $(SETUP) build + cd p && $(SETUP) register --inplace + # Put p1 into tmp1.d + cd p1 && $(SETUP) clean + cd p1 && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p1-0.1.0.0 --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp1.d + cd p1 && $(SETUP) build + cd p1 && $(SETUP) register --inplace + # This should work + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ + # So should this + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP1 -unit @unitR + # So should this + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR -unit @unitP1 + # So should this? + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitQ -unit @unitR + + +ifeq "$(CLEANUP)" "1" + $(MAKE) -s --no-print-directory clean +endif + +clean : + $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) + diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/all.T b/testsuite/tests/driver/multipleHomeUnits/different-db/all.T new file mode 100644 index 0000000000..5661d6a017 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/all.T @@ -0,0 +1,9 @@ +if config.cleanup: + cleanup = 'CLEANUP=1' +else: + cleanup = 'CLEANUP=0' + +test('different-db', + extra_files(['p/', 'q/', 'r/', 'p1/', 'unitP', 'unitQ', 'unitR', 'unitP1', 'Setup.hs']), + run_command, + ['$MAKE -s --no-print-directory different-db ' + cleanup]) diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/different-db.stdout b/testsuite/tests/driver/multipleHomeUnits/different-db/different-db.stdout new file mode 100644 index 0000000000..6d8e683223 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/different-db.stdout @@ -0,0 +1,10 @@ +[1 of 2] Compiling P[p-0.1.0.0] +[2 of 2] Compiling Q[q-0.1.0.0] +[1 of 2] Compiling P[p1-0.1.0.0] +[2 of 2] Compiling R[r-0.1.0.0] +[1 of 4] Compiling P[p-0.1.0.0] +[2 of 4] Compiling P[p1-0.1.0.0] +[3 of 4] Compiling Q[q-0.1.0.0] +[4 of 4] Compiling R[r-0.1.0.0] +[1 of 2] Compiling Q[q-0.1.0.0] +[2 of 2] Compiling R[r-0.1.0.0] diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p/P.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/p/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/p/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p/p.cabal b/testsuite/tests/driver/multipleHomeUnits/different-db/p/p.cabal new file mode 100644 index 0000000000..b0113ee1f1 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p/p.cabal @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p1/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/p1/p1.cabal b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/p1.cabal new file mode 100644 index 0000000000..62094863b1 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/p1/p1.cabal @@ -0,0 +1,11 @@ +name: p1 +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/q/Q.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/q/Q.hs new file mode 100644 index 0000000000..8c7bcdc87b --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/q/Q.hs @@ -0,0 +1,2 @@ +module Q where +import P diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/q/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/q/q.cabal b/testsuite/tests/driver/multipleHomeUnits/different-db/q/q.cabal new file mode 100644 index 0000000000..874f392569 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/q/q.cabal @@ -0,0 +1,11 @@ +name: q +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Q + build-depends: base, p + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/r/R.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/r/R.hs new file mode 100644 index 0000000000..d0701f9647 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/r/R.hs @@ -0,0 +1,2 @@ +module R where +import P diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/r/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/different-db/r/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/r/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/r/r.cabal b/testsuite/tests/driver/multipleHomeUnits/different-db/r/r.cabal new file mode 100644 index 0000000000..b2e8b1c92f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/r/r.cabal @@ -0,0 +1,11 @@ +name: r +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: R + build-depends: base, p1 + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/unitP b/testsuite/tests/driver/multipleHomeUnits/different-db/unitP new file mode 100644 index 0000000000..7b3b088b7e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/unitP @@ -0,0 +1 @@ +-working-dir p P -i -i. -package-db ../tmp.d -this-unit-id p-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/unitP1 b/testsuite/tests/driver/multipleHomeUnits/different-db/unitP1 new file mode 100644 index 0000000000..2aaa451ea4 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -i -i. -package-db ../tmp.d -this-unit-id p1-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/unitQ b/testsuite/tests/driver/multipleHomeUnits/different-db/unitQ new file mode 100644 index 0000000000..dcd9ae059a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/unitQ @@ -0,0 +1 @@ +-working-dir q Q -i -i. -package-db ../tmp.d -this-unit-id q-0.1.0.0 -package-id p-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/different-db/unitR b/testsuite/tests/driver/multipleHomeUnits/different-db/unitR new file mode 100644 index 0000000000..5317759b65 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/different-db/unitR @@ -0,0 +1 @@ +-working-dir r R -i -i. -package-db ../tmp1.d -this-unit-id r-0.1.0.0 -package-id p1-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/e/E.hs b/testsuite/tests/driver/multipleHomeUnits/e/E.hs new file mode 100644 index 0000000000..8728a5f758 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/e/E.hs @@ -0,0 +1,10 @@ +module E where + +-- Depends on another home unit B +import B +-- Depends on a package +import Control.Applicative + +e = b + +e' = show B diff --git a/testsuite/tests/driver/multipleHomeUnits/hi-dir/Makefile b/testsuite/tests/driver/multipleHomeUnits/hi-dir/Makefile new file mode 100644 index 0000000000..82606c1d70 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/hi-dir/Makefile @@ -0,0 +1,12 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +checkExists = [ -d $1 ] || echo $1 missing +checkNotExists = [ ! -d $1 ] || echo $1 not missing + +mhu-hidir: + '$(TEST_HC)' $(TEST_HC_OPTS) -unit @unitP1 -v0 + $(call checkNotExists,dist) + $(call checkExists, p1/dist) + diff --git a/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T b/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T new file mode 100644 index 0000000000..0dcb2fb607 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/hi-dir/all.T @@ -0,0 +1,6 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_hidir' + , [extra_files([ 'p1/', 'unitP1']) + ] + , makefile_test + , ['mhu-hidir']) diff --git a/testsuite/tests/driver/multipleHomeUnits/hi-dir/p1/Main.hs b/testsuite/tests/driver/multipleHomeUnits/hi-dir/p1/Main.hs new file mode 100644 index 0000000000..de106fe48f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/hi-dir/p1/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/testsuite/tests/driver/multipleHomeUnits/hi-dir/unitP1 b/testsuite/tests/driver/multipleHomeUnits/hi-dir/unitP1 new file mode 100644 index 0000000000..54fc79a25c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/hi-dir/unitP1 @@ -0,0 +1 @@ +-working-dir p1 Main -this-unit-id p1-0 -this-package-name p1 -hidir dist diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/all.T b/testsuite/tests/driver/multipleHomeUnits/instance-vis/all.T new file mode 100644 index 0000000000..81737c1f9c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/all.T @@ -0,0 +1 @@ +test('multipleHomeUnits_instance-vis', [extra_files([ 'p1/', 'p2', 'q', 'unitP1', 'unitP2', 'unitQ'])], multiunit_compile, [['unitP1', 'unitP2', 'unitQ'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/multipleHomeUnits_instance-vis.stderr b/testsuite/tests/driver/multipleHomeUnits/instance-vis/multipleHomeUnits_instance-vis.stderr new file mode 100644 index 0000000000..89b10089dd --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/multipleHomeUnits_instance-vis.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling P[p1-0] +[2 of 3] Compiling P[p2-0] +[3 of 3] Compiling Q[q-0] diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/instance-vis/p1/P.hs new file mode 100644 index 0000000000..bb4fc0ff7d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/p1/P.hs @@ -0,0 +1,7 @@ +module P where + +class Test x where + test :: x -> x + +data P = P + diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/p2/P.hs b/testsuite/tests/driver/multipleHomeUnits/instance-vis/p2/P.hs new file mode 100644 index 0000000000..155d965f67 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/p2/P.hs @@ -0,0 +1,11 @@ +-- The same as the module in p1, but doesn't contain an instance +module P where + +class Test x where + test :: x -> x + +data P = P + +instance Test P where + test = id + diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/q/Q.hs b/testsuite/tests/driver/multipleHomeUnits/instance-vis/q/Q.hs new file mode 100644 index 0000000000..950585bf38 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/q/Q.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +module Q where + +import "p2" P + +q = test P diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP1 b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP1 new file mode 100644 index 0000000000..785cdd963d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -this-package-name p1 diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP2 b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP2 new file mode 100644 index 0000000000..26d789c44f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitP2 @@ -0,0 +1 @@ +-working-dir p2 P -this-unit-id p2-0 -this-package-name p2 diff --git a/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitQ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitQ new file mode 100644 index 0000000000..7c7422014c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/instance-vis/unitQ @@ -0,0 +1 @@ +-working-dir q Q -this-unit-id q-0 -this-package-name q -package-id p1-0 -package-id p2-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile new file mode 100644 index 0000000000..ff67f37808 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Makefile @@ -0,0 +1,41 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=../Setup -v0 + +mhu-closure: clean + $(MAKE) -s --no-print-directory clean + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup + cd p && $(SETUP) clean + cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd p && $(SETUP) build + cd p && $(SETUP) register --inplace + cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=q-0.1.0.0 --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd q && $(SETUP) build + cd q && $(SETUP) register --inplace + cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=r-0.1.0.0 --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd r && $(SETUP) build + cd r && $(SETUP) register --inplace + # This should work + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP + # So should this + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ + # So should this + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR + # This should error with a closure message + ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR + # This should work, even though r1 is not in the package db + '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1 + # This should fail, even though r1 is not in the package db + ! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1 + + +ifeq "$(CLEANUP)" "1" + $(MAKE) -s --no-print-directory clean +endif + +clean : + $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) + diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T new file mode 100644 index 0000000000..16fb06efa9 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/all.T @@ -0,0 +1,9 @@ +if config.cleanup: + cleanup = 'CLEANUP=1' +else: + cleanup = 'CLEANUP=0' + +test('mhu-closure', + extra_files(['p/', 'q/', 'r/', 'r1/', 'unitP', 'unitQ', 'unitR', 'unitR1', 'Setup.hs']), + run_command, + ['$MAKE -s --no-print-directory mhu-closure ' + cleanup]) diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr new file mode 100644 index 0000000000..115d141070 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr @@ -0,0 +1,10 @@ + +<command line>: error: + Home units are not closed. + It is necessary to also load the following units: + - q-0.1.0.0 + +<command line>: error: + Home units are not closed. + It is necessary to also load the following units: + - q-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout new file mode 100644 index 0000000000..0afbe831dc --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout @@ -0,0 +1,9 @@ +[1 of 1] Compiling P +[1 of 2] Compiling P[p-0.1.0.0] +[2 of 2] Compiling Q[q-0.1.0.0] +[1 of 3] Compiling P[p-0.1.0.0] +[2 of 3] Compiling Q[q-0.1.0.0] +[3 of 3] Compiling R[r-0.1.0.0] +[1 of 3] Compiling P[p-0.1.0.0] +[2 of 3] Compiling Q[q-0.1.0.0] +[3 of 3] Compiling R[r1-0.1.0.0] diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/P.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/p.cabal b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/p.cabal new file mode 100644 index 0000000000..b0113ee1f1 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/p/p.cabal @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Q.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Q.hs new file mode 100644 index 0000000000..8c7bcdc87b --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Q.hs @@ -0,0 +1,2 @@ +module Q where +import P diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/q.cabal b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/q.cabal new file mode 100644 index 0000000000..874f392569 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/q/q.cabal @@ -0,0 +1,11 @@ +name: q +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Q + build-depends: base, p + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/R.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/R.hs new file mode 100644 index 0000000000..01f057a907 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/R.hs @@ -0,0 +1,2 @@ +module R where +import Q diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/r.cabal b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/r.cabal new file mode 100644 index 0000000000..2a9e09cab0 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r/r.cabal @@ -0,0 +1,11 @@ +name: r +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: R + build-depends: base, q + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/R.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/R.hs new file mode 100644 index 0000000000..01f057a907 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/R.hs @@ -0,0 +1,2 @@ +module R where +import Q diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/Setup.hs b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/r1.cabal b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/r1.cabal new file mode 100644 index 0000000000..b87a73276e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/r1/r1.cabal @@ -0,0 +1,11 @@ +name: r1 +version: 0.1.0.0 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: R + build-depends: base, q + default-language: Haskell2010 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitP b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitP new file mode 100644 index 0000000000..7b3b088b7e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitP @@ -0,0 +1 @@ +-working-dir p P -i -i. -package-db ../tmp.d -this-unit-id p-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitQ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitQ new file mode 100644 index 0000000000..dcd9ae059a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitQ @@ -0,0 +1 @@ +-working-dir q Q -i -i. -package-db ../tmp.d -this-unit-id q-0.1.0.0 -package-id p-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR new file mode 100644 index 0000000000..2535bd7d14 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR @@ -0,0 +1 @@ +-working-dir r R -i -i. -package-db ../tmp.d -this-unit-id r-0.1.0.0 -package-id q-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR1 b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR1 new file mode 100644 index 0000000000..9bb366c78e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/mhu-closure/unitR1 @@ -0,0 +1 @@ +-working-dir r1 R -i -i. -package-db ../tmp.d -this-unit-id r1-0.1.0.0 -package-id q-0.1.0.0 diff --git a/testsuite/tests/driver/multipleHomeUnits/module-visibility-import/MV.hs b/testsuite/tests/driver/multipleHomeUnits/module-visibility-import/MV.hs new file mode 100644 index 0000000000..9fcfb91652 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/module-visibility-import/MV.hs @@ -0,0 +1,5 @@ +module MV where + +import MV1 +-- Should fail as MV2 is not visible externally. +import MV2 diff --git a/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV1.hs b/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV1.hs new file mode 100644 index 0000000000..904bfa5b96 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV1.hs @@ -0,0 +1 @@ +module MV1 where diff --git a/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV2.hs b/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV2.hs new file mode 100644 index 0000000000..7b8be20a5a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/module-visibility/MV2.hs @@ -0,0 +1 @@ +module MV2 where diff --git a/testsuite/tests/driver/multipleHomeUnits/multiGHCi.script b/testsuite/tests/driver/multipleHomeUnits/multiGHCi.script new file mode 100644 index 0000000000..f4fd0056d5 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multiGHCi.script @@ -0,0 +1,2 @@ +:r +:l abc diff --git a/testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr b/testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr new file mode 100644 index 0000000000..5829562213 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multiGHCi.stderr @@ -0,0 +1 @@ +Command is not supported (yet) in multi-mode diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stderr new file mode 100644 index 0000000000..6d018258a0 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling A[a] +[2 of 2] Compiling B[b] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stdout new file mode 100644 index 0000000000..f3121c04e6 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits001.stdout @@ -0,0 +1,2 @@ +[1 of 2] Compiling A ( a/A.hs, a/A.o )[a] +[2 of 2] Compiling B ( b/B.hs, b/B.o )[b] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits002.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits002.stdout new file mode 100644 index 0000000000..5c1736d41e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits002.stdout @@ -0,0 +1,6 @@ +[1 of 4] Compiling Main[c] +[2 of 4] Compiling Main[d] +[3 of 4] Linking ./c/C[c] +[4 of 4] Linking ./d/D[d] +unit C compiled successfully +unit D compiled successfully diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits003.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits003.stdout new file mode 100644 index 0000000000..8369f9246e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits003.stdout @@ -0,0 +1,8 @@ +[1 of 6] Compiling A[a] +[2 of 6] Compiling B[b] +[3 of 6] Compiling Main[c] +[4 of 6] Compiling Main[d] +[5 of 6] Linking ./c/C[c] +[6 of 6] Linking ./d/D[d] +unit C compiled successfully +unit D compiled successfully diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stderr new file mode 100644 index 0000000000..ea843cb688 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling B[b] +[2 of 2] Compiling E[e] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stdout new file mode 100644 index 0000000000..6168f3a0d2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004.stdout @@ -0,0 +1,2 @@ +[1 of 2] Compiling B ( b/B.hs, b/B.o )[b] +[2 of 2] Compiling E ( e/E.hs, e/E.o )[e] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004_recomp.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004_recomp.stdout new file mode 100644 index 0000000000..ea843cb688 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits004_recomp.stdout @@ -0,0 +1,2 @@ +[1 of 2] Compiling B[b] +[2 of 2] Compiling E[e] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr new file mode 100644 index 0000000000..b1cd097d13 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stderr @@ -0,0 +1,5 @@ + +module-visibility-import/MV.hs:5:1: error: + Could not load module ‘MV2’ + it is a hidden module in the package ‘mv’ + Use -v (or `:set -v` in ghci) to see a list of the files searched for. diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stdout new file mode 100644 index 0000000000..3120a98467 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsModuleVisibility.stdout @@ -0,0 +1,3 @@ +[1 of 3] Compiling MV1[mv] +[2 of 3] Compiling MV[mvi] +[3 of 3] Compiling MV2[mv] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stderr new file mode 100644 index 0000000000..9b05b03e0c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling B[b] +[2 of 3] Compiling B[b2] +[3 of 3] Compiling P[p] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stdout new file mode 100644 index 0000000000..5f37c20671 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnitsPackageImports.stdout @@ -0,0 +1,3 @@ +[1 of 3] Compiling B ( b/B.hs, b/B.o )[b] +[2 of 3] Compiling B ( b2/B.hs, b2/B.o )[b2] +[3 of 3] Compiling P ( package-imports/P.hs, package-imports/P.o )[p] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_callstack.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_callstack.stderr new file mode 100644 index 0000000000..0d7d75b1ee --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_callstack.stderr @@ -0,0 +1,3 @@ +Main: test +CallStack (from HasCallStack): + error, called at callstack/./Main.hs:4:8 in main:Main diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cfile.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cfile.stderr new file mode 100644 index 0000000000..e6c27f93f2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cfile.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling C diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp.stderr new file mode 100644 index 0000000000..01e308dcdb --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling CPPIncludes_Down +[2 of 2] Compiling CPPIncludes diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp2.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp2.stderr new file mode 100644 index 0000000000..158f3ed0cb --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_cpp2.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling CPPIncludes_Down[cpp] +[2 of 3] Compiling CPPIncludes[cpp] +[3 of 3] Compiling M[cpp-import] diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stderr new file mode 100644 index 0000000000..2c01f0ed7d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling A diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stdout new file mode 100644 index 0000000000..eb2bcb2e30 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single1.stdout @@ -0,0 +1 @@ +[1 of 1] Compiling A ( a/A.hs, a/A.o ) diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stderr new file mode 100644 index 0000000000..cbfbd65e52 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling B diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stdout new file mode 100644 index 0000000000..e048444c9c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single2.stdout @@ -0,0 +1 @@ +[1 of 1] Compiling B ( b/B.hs, b/B.o ) diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stderr new file mode 100644 index 0000000000..e964210090 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling Main +[2 of 2] Linking ./c/C diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stdout new file mode 100644 index 0000000000..fcb27f53a8 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single3.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling Main ( c/C.hs, c/C.o ) +[2 of 2] Linking ./c/C +unit C compiled successfully diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stderr new file mode 100644 index 0000000000..834eb4c2c9 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling Main +[2 of 2] Linking ./d/D diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stdout new file mode 100644 index 0000000000..b6f255ae82 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single4.stdout @@ -0,0 +1,3 @@ +[1 of 2] Compiling Main ( d/C.hs, d/C.o ) +[2 of 2] Linking ./d/D +unit D compiled successfully diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stderr b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stderr new file mode 100644 index 0000000000..02e1312bf0 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling TH diff --git a/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stdout b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stdout new file mode 100644 index 0000000000..f0e62c8a55 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/multipleHomeUnits_single5.stdout @@ -0,0 +1 @@ +[1 of 1] Compiling TH ( th/TH.hs, th/TH.o, th/TH.dyn_o ) diff --git a/testsuite/tests/driver/multipleHomeUnits/o-dir/Makefile b/testsuite/tests/driver/multipleHomeUnits/o-dir/Makefile new file mode 100644 index 0000000000..3389ecbe36 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-dir/Makefile @@ -0,0 +1,12 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +checkExists = [ -d $1 ] || echo $1 missing +checkNotExists = [ ! -d $1 ] || echo $1 not missing + +mhu-odir: + '$(TEST_HC)' $(TEST_HC_OPTS) -unit @unitP1 -v0 + $(call checkNotExists,dist) + $(call checkExists, p1/dist) + diff --git a/testsuite/tests/driver/multipleHomeUnits/o-dir/all.T b/testsuite/tests/driver/multipleHomeUnits/o-dir/all.T new file mode 100644 index 0000000000..9e3d92dedc --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-dir/all.T @@ -0,0 +1,6 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_odir' + , [extra_files([ 'p1/', 'unitP1']) + ] + , makefile_test + , ['mhu-odir']) diff --git a/testsuite/tests/driver/multipleHomeUnits/o-dir/p1/Main.hs b/testsuite/tests/driver/multipleHomeUnits/o-dir/p1/Main.hs new file mode 100644 index 0000000000..de106fe48f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-dir/p1/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/testsuite/tests/driver/multipleHomeUnits/o-dir/unitP1 b/testsuite/tests/driver/multipleHomeUnits/o-dir/unitP1 new file mode 100644 index 0000000000..6fd7f37bf5 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-dir/unitP1 @@ -0,0 +1 @@ +-working-dir p1 Main -this-unit-id p1-0 -this-package-name p1 -odir dist diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/Makefile b/testsuite/tests/driver/multipleHomeUnits/o-files/Makefile new file mode 100644 index 0000000000..5d1c975f05 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/Makefile @@ -0,0 +1,7 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +setup: + '$(TEST_HC)' $(TEST_HC_OPTS) -c p1/hello.c + diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/all.T b/testsuite/tests/driver/multipleHomeUnits/o-files/all.T new file mode 100644 index 0000000000..0133545ea9 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/all.T @@ -0,0 +1,6 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_o-files' + , [extra_files([ 'p1/', 'unitP1']) + , pre_cmd('$MAKE -s --no-print-directory setup')] + , multiunit_compile + , [['unitP1'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/multipleHomeUnits_o-files.stderr b/testsuite/tests/driver/multipleHomeUnits/o-files/multipleHomeUnits_o-files.stderr new file mode 100644 index 0000000000..9310e7f32a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/multipleHomeUnits_o-files.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling Main +[2 of 2] Linking p1/./Main diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/p1/Main.hs b/testsuite/tests/driver/multipleHomeUnits/o-files/p1/Main.hs new file mode 100644 index 0000000000..de106fe48f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/p1/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/p1/hello.c b/testsuite/tests/driver/multipleHomeUnits/o-files/p1/hello.c new file mode 100644 index 0000000000..98119643a7 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/p1/hello.c @@ -0,0 +1,6 @@ +#include <stdio.h> + +int foo() +{ + return 0; +} diff --git a/testsuite/tests/driver/multipleHomeUnits/o-files/unitP1 b/testsuite/tests/driver/multipleHomeUnits/o-files/unitP1 new file mode 100644 index 0000000000..2f65369383 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/o-files/unitP1 @@ -0,0 +1 @@ +-working-dir p1 Main -this-unit-id p1-0 -this-package-name p1 hello.o diff --git a/testsuite/tests/driver/multipleHomeUnits/package-imports/P.hs b/testsuite/tests/driver/multipleHomeUnits/package-imports/P.hs new file mode 100644 index 0000000000..1f73f9804b --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/package-imports/P.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PackageImports #-} +module P where + +import "b" B diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/all.T b/testsuite/tests/driver/multipleHomeUnits/pi-roots/all.T new file mode 100644 index 0000000000..4c188955c1 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/all.T @@ -0,0 +1,2 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_pi_duplicate', [extra_files([ 'p1/', 'p2', 'unitP1', 'unitP2'])], multiunit_compile, [['unitP1', 'unitP2'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/multipleHomeUnits_pi_duplicate.stderr b/testsuite/tests/driver/multipleHomeUnits/pi-roots/multipleHomeUnits_pi_duplicate.stderr new file mode 100644 index 0000000000..7c57f70a9e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/multipleHomeUnits_pi_duplicate.stderr @@ -0,0 +1,3 @@ +[1 of 3] Compiling P[p1-0] +[2 of 3] Compiling P[p2-0] +[3 of 3] Compiling Q[p2-0] diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p1/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p1/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/P.hs b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/P.hs new file mode 100644 index 0000000000..a007978103 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/P.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PackageImports #-} +module P where + +import "p1" P diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/Q.hs b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/Q.hs new file mode 100644 index 0000000000..bfca0886ea --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/p2/Q.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PackageImports #-} +module Q where + +import "this" P diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP1 b/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP1 new file mode 100644 index 0000000000..785cdd963d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -this-package-name p1 diff --git a/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP2 b/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP2 new file mode 100644 index 0000000000..8f6966eee4 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/pi-roots/unitP2 @@ -0,0 +1 @@ +-working-dir p2 P Q -this-unit-id p2-0 -this-package-name p2 -package-id p1-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/reexport/all.T b/testsuite/tests/driver/multipleHomeUnits/reexport/all.T new file mode 100644 index 0000000000..9faa9e7a51 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/reexport/all.T @@ -0,0 +1,2 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_reexport', [extra_files([ 'p1/', 'p2/', 'unitP1', 'unitP2'])], multiunit_compile, [['unitP1', 'unitP2'], '-v0 -fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/reexport/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/reexport/p1/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/reexport/p1/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/reexport/p2/Q.hs b/testsuite/tests/driver/multipleHomeUnits/reexport/p2/Q.hs new file mode 100644 index 0000000000..5d66f6fe48 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/reexport/p2/Q.hs @@ -0,0 +1,3 @@ +module Q where + +import Data.Text diff --git a/testsuite/tests/driver/multipleHomeUnits/reexport/unitP1 b/testsuite/tests/driver/multipleHomeUnits/reexport/unitP1 new file mode 100644 index 0000000000..59036e4a55 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/reexport/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -package text -this-package-name p1 -reexported-module Data.Text diff --git a/testsuite/tests/driver/multipleHomeUnits/reexport/unitP2 b/testsuite/tests/driver/multipleHomeUnits/reexport/unitP2 new file mode 100644 index 0000000000..aac500965e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/reexport/unitP2 @@ -0,0 +1 @@ +-working-dir p2 Q -this-unit-id p2-0 -this-package-name p2 -hide-all-packages -package-id p1-0 -package base diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/Makefile b/testsuite/tests/driver/multipleHomeUnits/self-import/Makefile new file mode 100644 index 0000000000..ca859a602c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/Makefile @@ -0,0 +1,9 @@ +TOP=../../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +multipleHomeUnits_self-import: + '$(TEST_HC)' $(TEST_HC_OPTS) -unit @unitP1 -unit @unitP2 -v0 + # This should do nothing + '$(TEST_HC)' $(TEST_HC_OPTS) -unit @unitP1 -unit @unitP2 + diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/all.T b/testsuite/tests/driver/multipleHomeUnits/self-import/all.T new file mode 100644 index 0000000000..a772a39083 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/all.T @@ -0,0 +1,4 @@ +# This tests that recompilation logic works if you import a module with the same +# name +test('multipleHomeUnits_self-import', [extra_files([ 'p1/', 'p2/', 'unitP1', 'unitP2'])], makefile_test, []) + diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/self-import/p1/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/p1/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/p2/P.hs b/testsuite/tests/driver/multipleHomeUnits/self-import/p2/P.hs new file mode 100644 index 0000000000..a007978103 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/p2/P.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE PackageImports #-} +module P where + +import "p1" P diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/unitP1 b/testsuite/tests/driver/multipleHomeUnits/self-import/unitP1 new file mode 100644 index 0000000000..785cdd963d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -this-package-name p1 diff --git a/testsuite/tests/driver/multipleHomeUnits/self-import/unitP2 b/testsuite/tests/driver/multipleHomeUnits/self-import/unitP2 new file mode 100644 index 0000000000..64d62d01e2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/self-import/unitP2 @@ -0,0 +1 @@ +-working-dir p2 P -this-unit-id p2-0 -this-package-name p2 -package-id p1-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T b/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T new file mode 100644 index 0000000000..74d9baf953 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/target-file-path/all.T @@ -0,0 +1,6 @@ +# This test checks that getRootSummary doesn't cross package boundaries. +test('multipleHomeUnits_target-file-path' + , [extra_files([ 'p1/', 'unitP1']) + ] + , multiunit_compile + , [['unitP1'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/target-file-path/multipleHomeUnits_target-file-path.stderr b/testsuite/tests/driver/multipleHomeUnits/target-file-path/multipleHomeUnits_target-file-path.stderr new file mode 100644 index 0000000000..345d8d960f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/target-file-path/multipleHomeUnits_target-file-path.stderr @@ -0,0 +1,2 @@ +[1 of 2] Compiling Main +[2 of 2] Linking p1/Main diff --git a/testsuite/tests/driver/multipleHomeUnits/target-file-path/p1/Main.hs b/testsuite/tests/driver/multipleHomeUnits/target-file-path/p1/Main.hs new file mode 100644 index 0000000000..de106fe48f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/target-file-path/p1/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = return () diff --git a/testsuite/tests/driver/multipleHomeUnits/target-file-path/unitP1 b/testsuite/tests/driver/multipleHomeUnits/target-file-path/unitP1 new file mode 100644 index 0000000000..b221fb65c2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/target-file-path/unitP1 @@ -0,0 +1 @@ +-working-dir p1 Main.hs -this-unit-id p1-0 -this-package-name p1 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/all.T b/testsuite/tests/driver/multipleHomeUnits/th-deps/all.T new file mode 100644 index 0000000000..4e89f8b296 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/all.T @@ -0,0 +1 @@ +test('multipleHomeUnits_th-deps', [extra_files([ 'p1/', 'p2', 'q', 'unitP1', 'unitP2', 'unitQ'])], multiunit_compile, [['unitP1', 'unitP2', 'unitQ'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/multipleHomeUnits_th-deps.stderr b/testsuite/tests/driver/multipleHomeUnits/th-deps/multipleHomeUnits_th-deps.stderr new file mode 100644 index 0000000000..90fe8f8f3b --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/multipleHomeUnits_th-deps.stderr @@ -0,0 +1,4 @@ +[1 of 3] Compiling P[p1-0] +[2 of 3] Compiling P[p2-0] +[3 of 3] Compiling Q[q-0] +2 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/th-deps/p1/P.hs new file mode 100644 index 0000000000..8a802e691f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/p1/P.hs @@ -0,0 +1,3 @@ +module P where + +p = 1 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/p2/P.hs b/testsuite/tests/driver/multipleHomeUnits/th-deps/p2/P.hs new file mode 100644 index 0000000000..13c0fbabec --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/p2/P.hs @@ -0,0 +1,4 @@ +-- The same as the module in p1, but doesn't contain an instance +module P where + +p = 2 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/q/Q.hs b/testsuite/tests/driver/multipleHomeUnits/th-deps/q/Q.hs new file mode 100644 index 0000000000..2ede07e858 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/q/Q.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TemplateHaskell #-} +module Q where + +import "p2" P +import Control.Monad.IO.Class +import System.IO + +q = $(liftIO (print p >> hFlush stdout) >> [| () |]) diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP1 b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP1 new file mode 100644 index 0000000000..785cdd963d --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -this-package-name p1 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP2 b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP2 new file mode 100644 index 0000000000..26d789c44f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitP2 @@ -0,0 +1 @@ +-working-dir p2 P -this-unit-id p2-0 -this-package-name p2 diff --git a/testsuite/tests/driver/multipleHomeUnits/th-deps/unitQ b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitQ new file mode 100644 index 0000000000..7c7422014c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th-deps/unitQ @@ -0,0 +1 @@ +-working-dir q Q -this-unit-id q-0 -this-package-name q -package-id p1-0 -package-id p2-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/th/TH.hs b/testsuite/tests/driver/multipleHomeUnits/th/TH.hs new file mode 100644 index 0000000000..12bf9fcaf7 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th/TH.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module TH where + +import Language.Haskell.TH.Syntax +import System.Directory +import System.FilePath + +th = $(makeRelativeToProject "data" >>= runIO . readFile >> [| () |]) diff --git a/testsuite/tests/driver/multipleHomeUnits/th/data b/testsuite/tests/driver/multipleHomeUnits/th/data new file mode 100644 index 0000000000..1269488f7f --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/th/data @@ -0,0 +1 @@ +data diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/A.hs b/testsuite/tests/driver/multipleHomeUnits/unit-clash/A.hs new file mode 100644 index 0000000000..d843c00b78 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/A.hs @@ -0,0 +1 @@ +module A where diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/B.hs b/testsuite/tests/driver/multipleHomeUnits/unit-clash/B.hs new file mode 100644 index 0000000000..c759bc2d13 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/B.hs @@ -0,0 +1 @@ +module B where diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/all.T b/testsuite/tests/driver/multipleHomeUnits/unit-clash/all.T new file mode 100644 index 0000000000..b993ad940a --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/all.T @@ -0,0 +1,2 @@ +# This test checks for clashing home unit ids +test('multipleHomeUnits_unit-clash', [extra_files([ 'A.hs', 'B.hs', 'unitA', 'unitB'])], multiunit_compile_fail, [['unitA', 'unitB'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/multipleHomeUnits_unit-clash.stderr b/testsuite/tests/driver/multipleHomeUnits/unit-clash/multipleHomeUnits_unit-clash.stderr new file mode 100644 index 0000000000..eb67b49d70 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/multipleHomeUnits_unit-clash.stderr @@ -0,0 +1,3 @@ +<command line>: Multiple units with the same unit-id: + - main defined in @unitB + - main defined in @unitA diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitA b/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitA new file mode 100644 index 0000000000..f70f10e4db --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitA @@ -0,0 +1 @@ +A diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitB b/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitB new file mode 100644 index 0000000000..223b7836fb --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-clash/unitB @@ -0,0 +1 @@ +B diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/all.T b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/all.T new file mode 100644 index 0000000000..9d867e0254 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/all.T @@ -0,0 +1,2 @@ +# This test checks that cycles between units are not allowed. +test('multipleHomeUnits_unit-cycles', [extra_files([ 'p1/', 'p2/', 'unitP1', 'unitP2'])], multiunit_compile_fail, [['unitP1', 'unitP2'], '-fhide-source-paths']) diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/multipleHomeUnits_unit-cycles.stderr b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/multipleHomeUnits_unit-cycles.stderr new file mode 100644 index 0000000000..8984264b40 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/multipleHomeUnits_unit-cycles.stderr @@ -0,0 +1,3 @@ +<command line>: Units form a dependency cycle: + - p1-0 depends on + - p2-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p1/P.hs b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p1/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p1/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p2/P.hs b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p2/P.hs new file mode 100644 index 0000000000..fc4877ad85 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/p2/P.hs @@ -0,0 +1 @@ +module P where diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP1 b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP1 new file mode 100644 index 0000000000..df9b3b72af --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP1 @@ -0,0 +1 @@ +-working-dir p1 P -this-unit-id p1-0 -this-package-name p1 -package-id p2-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP2 b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP2 new file mode 100644 index 0000000000..64d62d01e2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unit-cycles/unitP2 @@ -0,0 +1 @@ +-working-dir p2 P -this-unit-id p2-0 -this-package-name p2 -package-id p1-0 diff --git a/testsuite/tests/driver/multipleHomeUnits/unitA b/testsuite/tests/driver/multipleHomeUnits/unitA new file mode 100644 index 0000000000..e895fcde79 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitA @@ -0,0 +1 @@ +-i -i./a A -this-unit-id a diff --git a/testsuite/tests/driver/multipleHomeUnits/unitB b/testsuite/tests/driver/multipleHomeUnits/unitB new file mode 100644 index 0000000000..2dc46fd64e --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitB @@ -0,0 +1 @@ +-i -i./b B -this-unit-id b -this-package-name b diff --git a/testsuite/tests/driver/multipleHomeUnits/unitB2 b/testsuite/tests/driver/multipleHomeUnits/unitB2 new file mode 100644 index 0000000000..a0ef2f8e7c --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitB2 @@ -0,0 +1 @@ +-i -i. -working-dir=b2 B -this-unit-id b2 -this-package-name b2 diff --git a/testsuite/tests/driver/multipleHomeUnits/unitC b/testsuite/tests/driver/multipleHomeUnits/unitC new file mode 100644 index 0000000000..b0397e814b --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitC @@ -0,0 +1 @@ +-i c/C.hs -o ./c/C -this-unit-id c diff --git a/testsuite/tests/driver/multipleHomeUnits/unitCFile b/testsuite/tests/driver/multipleHomeUnits/unitCFile new file mode 100644 index 0000000000..751d981fd2 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitCFile @@ -0,0 +1 @@ +-working-dir c-file C c-file/c.c -Iinclude diff --git a/testsuite/tests/driver/multipleHomeUnits/unitCPPImport b/testsuite/tests/driver/multipleHomeUnits/unitCPPImport new file mode 100644 index 0000000000..3bdd7a0123 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitCPPImport @@ -0,0 +1 @@ +-i -i. -working-dir=cpp-import M -this-unit-id cpp-import -package-id cpp diff --git a/testsuite/tests/driver/multipleHomeUnits/unitCPPIncludes b/testsuite/tests/driver/multipleHomeUnits/unitCPPIncludes new file mode 100644 index 0000000000..4f23e974a1 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitCPPIncludes @@ -0,0 +1 @@ +-i -i. -working-dir=cpp-includes CPPIncludes -this-unit-id cpp -Iinclude -optP-include -optPinclude/header2.h diff --git a/testsuite/tests/driver/multipleHomeUnits/unitCallstack b/testsuite/tests/driver/multipleHomeUnits/unitCallstack new file mode 100644 index 0000000000..fe8223bba0 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitCallstack @@ -0,0 +1 @@ +-working-dir callstack Main diff --git a/testsuite/tests/driver/multipleHomeUnits/unitD b/testsuite/tests/driver/multipleHomeUnits/unitD new file mode 100644 index 0000000000..e7c3387599 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitD @@ -0,0 +1 @@ +-i d/C.hs -o ./d/D -this-unit-id d diff --git a/testsuite/tests/driver/multipleHomeUnits/unitE b/testsuite/tests/driver/multipleHomeUnits/unitE new file mode 100644 index 0000000000..2a85ab3618 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitE @@ -0,0 +1 @@ +-i -i./e E -this-unit-id e -package-id b diff --git a/testsuite/tests/driver/multipleHomeUnits/unitMV b/testsuite/tests/driver/multipleHomeUnits/unitMV new file mode 100644 index 0000000000..bdbf58ba62 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitMV @@ -0,0 +1 @@ +-i -i. -working-dir=module-visibility MV1 MV2 -this-unit-id mv -hidden-module MV2 diff --git a/testsuite/tests/driver/multipleHomeUnits/unitMV-import b/testsuite/tests/driver/multipleHomeUnits/unitMV-import new file mode 100644 index 0000000000..1873edb0a3 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitMV-import @@ -0,0 +1 @@ +-i -i. -working-dir=module-visibility-import MV -this-unit-id mvi -package-id mv diff --git a/testsuite/tests/driver/multipleHomeUnits/unitPI b/testsuite/tests/driver/multipleHomeUnits/unitPI new file mode 100644 index 0000000000..72469be015 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitPI @@ -0,0 +1 @@ +-i -i. -working-dir=package-imports P -this-unit-id p -package-id b -package-id b2 diff --git a/testsuite/tests/driver/multipleHomeUnits/unitTH b/testsuite/tests/driver/multipleHomeUnits/unitTH new file mode 100644 index 0000000000..659dd4d6f4 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitTH @@ -0,0 +1 @@ +-i -i. -working-dir=th TH -this-unit-id th -package filepath -package directory diff --git a/testsuite/tests/driver/multipleHomeUnits/unitTH1 b/testsuite/tests/driver/multipleHomeUnits/unitTH1 new file mode 100644 index 0000000000..85f7005b62 --- /dev/null +++ b/testsuite/tests/driver/multipleHomeUnits/unitTH1 @@ -0,0 +1 @@ +-i -i. -working-dir=th TH.hs -this-unit-id th -package filepath -package directory diff --git a/testsuite/tests/driver/recomp007/recomp007.stdout b/testsuite/tests/driver/recomp007/recomp007.stdout index 1160663b4d..c6b194ef17 100644 --- a/testsuite/tests/driver/recomp007/recomp007.stdout +++ b/testsuite/tests/driver/recomp007/recomp007.stdout @@ -1,6 +1,6 @@ "1.0" Preprocessing executable 'test' for b-1.0.. Building executable 'test' for b-1.0.. -[1 of 2] Compiling B ( B.hs, dist/build/test/test-tmp/B.o ) [A package changed] -Linking dist/build/test/test ... +[1 of 3] Compiling B ( B.hs, dist/build/test/test-tmp/B.o ) [A package changed] +[3 of 3] Linking dist/build/test/test [Objects changed] "2.0" diff --git a/testsuite/tests/driver/recomp011/recomp011.stdout b/testsuite/tests/driver/recomp011/recomp011.stdout index d3e0b92508..c320549f54 100644 --- a/testsuite/tests/driver/recomp011/recomp011.stdout +++ b/testsuite/tests/driver/recomp011/recomp011.stdout @@ -1,10 +1,10 @@ -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main 42 -[1 of 1] Compiling Main ( Main.hs, Main.o ) [B.hsinc changed] -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) [B.hsinc changed] +[2 of 2] Linking Main [Objects changed] 43 -[1 of 1] Compiling Main ( Main.hs, Main.o ) [A.hsinc changed] -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) [A.hsinc changed] +[2 of 2] Linking Main [Objects changed] 4343 4343 diff --git a/testsuite/tests/driver/recomp015/recomp015.stdout b/testsuite/tests/driver/recomp015/recomp015.stdout index a7dbad203a..2de39b6c87 100644 --- a/testsuite/tests/driver/recomp015/recomp015.stdout +++ b/testsuite/tests/driver/recomp015/recomp015.stdout @@ -1,6 +1,6 @@ -[1 of 1] Compiling Main ( Generate.hs, Generate.o ) -Linking Generate ... -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Generate.hs, Generate.o ) +[2 of 2] Linking Generate +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main Running main... Running main... diff --git a/testsuite/tests/driver/recomp019/recomp019.stdout b/testsuite/tests/driver/recomp019/recomp019.stdout index 413dad2e0f..300fe27867 100644 --- a/testsuite/tests/driver/recomp019/recomp019.stdout +++ b/testsuite/tests/driver/recomp019/recomp019.stdout @@ -1,11 +1,11 @@ first run -[1 of 3] Compiling B ( B.hs, B.o ) -[2 of 3] Compiling C ( C.hs, C.o ) -[3 of 3] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 4] Compiling B ( B.hs, B.o ) +[2 of 4] Compiling C ( C.hs, C.o ) +[3 of 4] Compiling Main ( Main.hs, Main.o ) +[4 of 4] Linking Main 5 [1 of 1] Compiling B ( B.hs, nothing ) [Source file changed] second run -[1 of 3] Compiling B ( B.hs, B.o ) [Missing object file] -Linking Main ... +[1 of 4] Compiling B ( B.hs, B.o ) [Missing object file] +[4 of 4] Linking Main [Objects changed] 15 diff --git a/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout b/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout index 86d6324225..ee1cbe982d 100644 --- a/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout +++ b/testsuite/tests/driver/recompChangedPackage/recompChangedPackage.stdout @@ -1,10 +1,10 @@ -[1 of 2] Compiling PLib ( PLib.hs, PLib.o ) -[2 of 2] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 3] Compiling PLib ( PLib.hs, PLib.o ) +[2 of 3] Compiling Main ( Main.hs, Main.o ) +[3 of 3] Linking Main "q" tmp.d q-0.1.0.0 -[1 of 1] Compiling Main ( Main.hs, Main.o ) [PLib removed] -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) [PLib removed] +[2 of 2] Linking Main [Objects changed] empty diff --git a/testsuite/tests/driver/retc001/retc001.stdout b/testsuite/tests/driver/retc001/retc001.stdout index e5d374608e..a5bdd0597e 100644 --- a/testsuite/tests/driver/retc001/retc001.stdout +++ b/testsuite/tests/driver/retc001/retc001.stdout @@ -1,7 +1,7 @@ -[1 of 3] Compiling A ( A.hs, nothing ) -[2 of 3] Compiling B ( B.hs, nothing ) -[3 of 3] Compiling Main ( C.hs, nothing ) +[1 of 4] Compiling A ( A.hs, nothing ) +[2 of 4] Compiling B ( B.hs, nothing ) +[3 of 4] Compiling Main ( C.hs, nothing ) Middle End -[2 of 3] Compiling B ( B.hs, nothing ) [Source file changed] -[3 of 3] Compiling Main ( C.hs, nothing ) [B changed] +[2 of 4] Compiling B ( B.hs, nothing ) [Source file changed] +[3 of 4] Compiling Main ( C.hs, nothing ) [B changed] diff --git a/testsuite/tests/driver/should_fail/T10895.stderr b/testsuite/tests/driver/should_fail/T10895.stderr index 3ae52a3ef7..ff8a380809 100644 --- a/testsuite/tests/driver/should_fail/T10895.stderr +++ b/testsuite/tests/driver/should_fail/T10895.stderr @@ -1,4 +1,4 @@ <no location info>: error: - output was redirected with -o, but no output will be generated -because there is no Main module. + Output was redirected with -o, but no output will be generated. + There is no module named ‘Main’. diff --git a/testsuite/tests/driver/th-new-test/th-new-test.stdout b/testsuite/tests/driver/th-new-test/th-new-test.stdout index 7f31ce608f..5de19bdd0a 100644 --- a/testsuite/tests/driver/th-new-test/th-new-test.stdout +++ b/testsuite/tests/driver/th-new-test/th-new-test.stdout @@ -1,17 +1,17 @@ -[1 of 5] Compiling B -[2 of 5] Compiling A -[3 of 5] Compiling D -[4 of 5] Compiling C -[5 of 5] Compiling Main -Linking Main ... -[1 of 5] Compiling B [Source file changed] -[2 of 5] Compiling A [B[TH] changed] -Linking Main ... -[3 of 5] Compiling D [Source file changed] -[4 of 5] Compiling C [D[TH] changed] -Linking Main ... -[1 of 5] Compiling B [Source file changed] -[2 of 5] Compiling A [B[TH] changed] -[3 of 5] Compiling D [Source file changed] -[4 of 5] Compiling C [D[TH] changed] -Linking Main ... +[1 of 6] Compiling B +[2 of 6] Compiling A +[3 of 6] Compiling D +[4 of 6] Compiling C +[5 of 6] Compiling Main +[6 of 6] Linking Main +[1 of 6] Compiling B [Source file changed] +[2 of 6] Compiling A [B[TH] changed] +[6 of 6] Linking Main [Objects changed] +[3 of 6] Compiling D [Source file changed] +[4 of 6] Compiling C [D[TH] changed] +[6 of 6] Linking Main [Objects changed] +[1 of 6] Compiling B [Source file changed] +[2 of 6] Compiling A [B[TH] changed] +[3 of 6] Compiling D [Source file changed] +[4 of 6] Compiling C [D[TH] changed] +[6 of 6] Linking Main [Objects changed] diff --git a/testsuite/tests/ghc-api/T10052/T10052.stdout b/testsuite/tests/ghc-api/T10052/T10052.stdout index 1a909eb36f..2506dc338e 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.stdout +++ b/testsuite/tests/ghc-api/T10052/T10052.stdout @@ -1 +1 @@ -[1 of 1] Compiling Main ( T10052-input.hs, interpreted ) +[1 of 2] Compiling Main ( T10052-input.hs, interpreted ) diff --git a/testsuite/tests/ghc-api/T7478/T7478.stdout b/testsuite/tests/ghc-api/T7478/T7478.stdout index 372cf9bfa3..e2323ab013 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.stdout +++ b/testsuite/tests/ghc-api/T7478/T7478.stdout @@ -1,8 +1,8 @@ ----- 0 ------ -(0,"[1 of 2] Compiling B ( B.hs, B.o )") -(0,"[2 of 2] Compiling Main ( A.hs, A.o )") +(0,"[1 of 3] Compiling B ( B.hs, B.o )") +(0,"[2 of 3] Compiling Main ( A.hs, A.o )") ----- 1 ------ -(1,"[2 of 2] Compiling Main ( A.hs, A.o )") +(1,"[2 of 3] Compiling Main ( A.hs, A.o )") ----- 2 ------ -(2,"[1 of 1] Compiling Main ( C.hs, C.o )") -(2,"Linking A ...") +(2,"[1 of 2] Compiling Main ( C.hs, C.o )") +(2,"[2 of 2] Linking C") diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs index ca1740358f..e21063ef45 100644 --- a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs @@ -6,12 +6,13 @@ import GHC import GHC.Driver.Make import GHC.Driver.Session import GHC.Driver.Env -import GHC.Unit.Module.ModSummary (ExtendedModSummary(..)) +import GHC.Unit.Module.Graph import GHC.Unit.Finder import Control.Monad.IO.Class (liftIO) import Data.List (sort, stripPrefix) import Data.Either +import Data.Maybe import System.Environment import System.Directory @@ -48,18 +49,18 @@ main = do _emss <- downsweep hsc_env [] [] False - flushFinderCaches (hsc_FC hsc_env) (hsc_home_unit hsc_env) + flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) createDirectoryIfMissing False "mydir" renameFile "B.hs" "mydir/B.hs" - emss <- downsweep hsc_env [] [] False + (_, nodes) <- downsweep hsc_env [] [] False -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with -- (ms_location old_summary) like summariseFile used to instead of -- using the 'location' parameter we'd end up using the old location of -- the "B" module in this test. Make sure that doesn't happen. - hPrint stderr $ sort (map (ml_hs_file . ms_location) (map emsModSummary (rights emss))) + hPrint stderr $ sort (map (ml_hs_file . ms_location) (mapMaybe moduleGraphNodeModSum nodes)) writeMod :: [String] -> IO () writeMod src@(head -> stripPrefix "module " -> Just (takeWhile (/=' ') -> mod)) diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs index 7a0a3ccf8d..50442bf3f2 100644 --- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs @@ -6,10 +6,10 @@ import GHC import GHC.Driver.Make import GHC.Driver.Session -import GHC.Unit.Module.ModSummary (ExtendedModSummary(..)) import GHC.Utils.Outputable import GHC.Utils.Exception (ExceptionMonad) import GHC.Data.Bag +import GHC.Unit.Module.Graph import Control.Monad import Control.Monad.Catch as MC (handle) @@ -18,6 +18,7 @@ import Control.Exception import Data.IORef import Data.List (sort, find, stripPrefix, isPrefixOf, isSuffixOf) import Data.Either +import Data.Maybe import System.Environment import System.Exit @@ -167,11 +168,9 @@ go label mods cnd = setTargets [tgt] hsc_env <- getSession - emss <- liftIO $ downsweep hsc_env [] [] False - -- liftIO $ hPutStrLn stderr $ showSDoc (hsc_dflags hsc_env) $ ppr $ rights emss - -- liftIO $ hPrint stderr $ bagToList $ unionManyBags $ lefts emss + (_, nodes) <- liftIO $ downsweep hsc_env [] [] False - it label $ cnd (map emsModSummary (rights emss)) + it label $ cnd (mapMaybe moduleGraphNodeModSum nodes) writeMod :: [String] -> IO () diff --git a/testsuite/tests/ghci/scripts/T18330.stdout b/testsuite/tests/ghci/scripts/T18330.stdout index c020ae7dbb..c95aa0e11b 100644 --- a/testsuite/tests/ghci/scripts/T18330.stdout +++ b/testsuite/tests/ghci/scripts/T18330.stdout @@ -1,5 +1,6 @@ -GHCi, version 9.3.20210616: https://www.haskell.org/ghc/ :? for help -ghci> [1 of 1] Compiling Main ( shell.hs, interpreted ) +GHCi, version 9.3.20211019: https://www.haskell.org/ghc/ :? for help +ghci> [1 of 2] Compiling Main ( shell.hs, interpreted ) +[2 of 2] Linking shell Ok, one module loaded. ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) Ok, one module loaded. diff --git a/testsuite/tests/ghci/scripts/T20587.script b/testsuite/tests/ghci/scripts/T20587.script new file mode 100644 index 0000000000..7e318d79ae --- /dev/null +++ b/testsuite/tests/ghci/scripts/T20587.script @@ -0,0 +1,13 @@ +:l shell.hs +:def shell (\s -> do shell s; return "") + +:set -v1 -i -i. -ib -fhide-source-paths + +:shell mkdir b +:shell echo "module B where b = 0" > b/B.hs + +:l B + +:shell echo "module B where" > B.hs + +:reload diff --git a/testsuite/tests/ghci/scripts/T20587.stdout b/testsuite/tests/ghci/scripts/T20587.stdout new file mode 100644 index 0000000000..6ca6d9f15f --- /dev/null +++ b/testsuite/tests/ghci/scripts/T20587.stdout @@ -0,0 +1,4 @@ +[1 of 1] Compiling B +Ok, one module loaded. +[1 of 1] Compiling B [Source file changed] +Ok, one module loaded. diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index a5ca6d64d3..32e9cad7fc 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -350,3 +350,5 @@ test('T7388', normal, ghci_script, ['T7388.script']) test('T20627', normal, ghci_script, ['T20627.script']) test('T20473a', normal, ghci_script, ['T20473a.script']) test('T20473b', normal, ghci_script, ['T20473b.script']) +test('T20587', [extra_files(['../shell.hs'])], ghci_script, + ['T20587.script']) diff --git a/testsuite/tests/ghci/scripts/ghci021.stderr b/testsuite/tests/ghci/scripts/ghci021.stderr index ea7488174e..2e5a3d5a0e 100644 --- a/testsuite/tests/ghci/scripts/ghci021.stderr +++ b/testsuite/tests/ghci/scripts/ghci021.stderr @@ -1,2 +1,2 @@ -<no location info>: no such module: ‘ThisDoesNotExist’ +<no location info>: error: no such module: ‘main:ThisDoesNotExist’ diff --git a/testsuite/tests/hp2ps/T15904.stdout b/testsuite/tests/hp2ps/T15904.stdout index e77005b2eb..5005beaba7 100644 --- a/testsuite/tests/hp2ps/T15904.stdout +++ b/testsuite/tests/hp2ps/T15904.stdout @@ -1,5 +1,5 @@ -[1 of 1] Compiling T15904 ( T15904.hs, T15904.o ) -Linking "T15904" ... +[1 of 2] Compiling T15904 ( T15904.hs, T15904.o ) +[2 of 2] Linking "T15904" {"e": 2.72, "pi": 3.14} \ diff --git a/testsuite/tests/indexed-types/should_compile/impexp.stderr b/testsuite/tests/indexed-types/should_compile/impexp.stderr index 7ebebe9e03..c57f611d6f 100644 --- a/testsuite/tests/indexed-types/should_compile/impexp.stderr +++ b/testsuite/tests/indexed-types/should_compile/impexp.stderr @@ -1,2 +1,2 @@ -[1 of 2] Compiling Exp ( Exp.hs, Exp.o ) -[2 of 2] Compiling Imp ( Imp.hs, Imp.o ) +[1 of 3] Compiling Exp ( Exp.hs, Exp.o ) +[2 of 3] Compiling Imp ( Imp.hs, Imp.o ) diff --git a/testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout b/testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout index 548813e7a4..eac8528cdd 100644 --- a/testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout +++ b/testsuite/tests/llvm/should_run/subsections_via_symbols/subsections_via_symbols.stdout @@ -1,3 +1,3 @@ -[1 of 1] Compiling SymbolsViaSections ( SubsectionsViaSymbols.hs, SubsectionsViaSymbols.o ) -Linking subsections_via_symbols ... +[1 of 2] Compiling SymbolsViaSections ( SubsectionsViaSymbols.hs, SubsectionsViaSymbols.o ) +[2 of 2] Linking subsections_via_symbols .......... diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr index f2d5586103..086d951580 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr @@ -1,5 +1,5 @@ -[1 of 2] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o ) -[2 of 2] Compiling Main ( hasfieldfail01.hs, hasfieldfail01.o ) +[1 of 3] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o ) +[2 of 3] Compiling Main ( hasfieldfail01.hs, hasfieldfail01.o ) hasfieldfail01.hs:9:15: error: • No instance for (HasField "foo" T Int) diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr index 6f5e7588f1..fe4b469e62 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.stderr @@ -1,7 +1,7 @@ -[1 of 2] Compiling OverloadedRecFldsFail04_A ( OverloadedRecFldsFail04_A.hs, OverloadedRecFldsFail04_A.o ) -[2 of 2] Compiling Main ( overloadedrecfldsfail04.hs, overloadedrecfldsfail04.o ) +[1 of 3] Compiling OverloadedRecFldsFail04_A ( OverloadedRecFldsFail04_A.hs, OverloadedRecFldsFail04_A.o ) +[2 of 3] Compiling Main ( overloadedrecfldsfail04.hs, overloadedrecfldsfail04.o ) - overloadedrecfldsfail04.hs:9:6: +overloadedrecfldsfail04.hs:9:6: error: Ambiguous occurrence ‘I.x’ It could refer to either the field ‘x’, diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr index 254931a9bc..10e3b1ece8 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail06.stderr @@ -1,4 +1,4 @@ -[1 of 2] Compiling OverloadedRecFldsFail06_A ( OverloadedRecFldsFail06_A.hs, OverloadedRecFldsFail06_A.o ) +[1 of 3] Compiling OverloadedRecFldsFail06_A ( OverloadedRecFldsFail06_A.hs, OverloadedRecFldsFail06_A.o ) OverloadedRecFldsFail06_A.hs:9:15: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] Defined but not used: data constructor ‘MkUnused’ @@ -8,7 +8,7 @@ OverloadedRecFldsFail06_A.hs:9:42: warning: [-Wunused-top-binds (in -Wextra, -Wu OverloadedRecFldsFail06_A.hs:9:59: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] Defined but not used: ‘used_locally’ -[2 of 2] Compiling Main ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o ) +[2 of 3] Compiling Main ( overloadedrecfldsfail06.hs, overloadedrecfldsfail06.o ) overloadedrecfldsfail06.hs:7:1: error: [-Wunused-imports (in -Wextra), -Werror=unused-imports] The import of ‘Unused(unused), V(x), U(y), MkV, Unused’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr index 9be384b500..cf483418ce 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail10.stderr @@ -1,7 +1,7 @@ -[1 of 4] Compiling OverloadedRecFldsFail10_A ( OverloadedRecFldsFail10_A.hs, OverloadedRecFldsFail10_A.o ) -[2 of 4] Compiling OverloadedRecFldsFail10_B ( OverloadedRecFldsFail10_B.hs, OverloadedRecFldsFail10_B.o ) -[3 of 4] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o ) -[4 of 4] Compiling Main ( overloadedrecfldsfail10.hs, overloadedrecfldsfail10.o ) +[1 of 5] Compiling OverloadedRecFldsFail10_A ( OverloadedRecFldsFail10_A.hs, OverloadedRecFldsFail10_A.o ) +[2 of 5] Compiling OverloadedRecFldsFail10_B ( OverloadedRecFldsFail10_B.hs, OverloadedRecFldsFail10_B.o ) +[3 of 5] Compiling OverloadedRecFldsFail10_C ( OverloadedRecFldsFail10_C.hs, OverloadedRecFldsFail10_C.o ) +[4 of 5] Compiling Main ( overloadedrecfldsfail10.hs, overloadedrecfldsfail10.o ) overloadedrecfldsfail10.hs:6:20: error: Conflicting exports for ‘foo’: diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr index 687af43de1..a509f54beb 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr @@ -1,7 +1,7 @@ -[1 of 2] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o ) -[2 of 2] Compiling Main ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o ) +[1 of 3] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o ) +[2 of 3] Compiling Main ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o ) -overloadedrecfldsfail11.hs:5:15: +overloadedrecfldsfail11.hs:5:15: error: Ambiguous occurrence ‘foo’ It could refer to either the field ‘foo’, diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr index b51fb80cca..62f9cd3e3c 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr @@ -1,7 +1,7 @@ -[1 of 2] Compiling OverloadedRecFldsFail12_A ( OverloadedRecFldsFail12_A.hs, OverloadedRecFldsFail12_A.o ) -[2 of 2] Compiling Main ( overloadedrecfldsfail12.hs, overloadedrecfldsfail12.o ) +[1 of 3] Compiling OverloadedRecFldsFail12_A ( OverloadedRecFldsFail12_A.hs, OverloadedRecFldsFail12_A.o ) +[2 of 3] Compiling Main ( overloadedrecfldsfail12.hs, overloadedrecfldsfail12.o ) - overloadedrecfldsfail12.hs:13:5: +overloadedrecfldsfail12.hs:13:5: error: Ambiguous occurrence ‘foo’ It could refer to either the field ‘foo’, @@ -9,7 +9,7 @@ (and originally defined at OverloadedRecFldsFail12_A.hs:5:16-18) or the field ‘foo’, defined at overloadedrecfldsfail12.hs:6:16 - overloadedrecfldsfail12.hs:16:5: +overloadedrecfldsfail12.hs:16:5: error: Ambiguous occurrence ‘foo’ It could refer to either the field ‘foo’, diff --git a/testsuite/tests/parser/should_compile/T5243.stderr b/testsuite/tests/parser/should_compile/T5243.stderr index 450e001237..5211871a2e 100644 --- a/testsuite/tests/parser/should_compile/T5243.stderr +++ b/testsuite/tests/parser/should_compile/T5243.stderr @@ -1,3 +1,3 @@ -[1 of 2] Compiling T5243A ( T5243A.hs, T5243A.o ) -[2 of 2] Compiling Main ( T5243.hs, T5243.o ) -Linking T5243 ... +[1 of 3] Compiling T5243A ( T5243A.hs, T5243A.o ) +[2 of 3] Compiling Main ( T5243.hs, T5243.o ) +[3 of 3] Linking T5243 diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr index c53990475b..c9bb7f6647 100644 --- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail6.stderr @@ -1,5 +1,5 @@ -[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) - [2 of 2] Compiling Main ( RecordDotSyntaxFail6.hs, RecordDotSyntaxFail6.o ) +[1 of 3] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) +[2 of 3] Compiling Main ( RecordDotSyntaxFail6.hs, RecordDotSyntaxFail6.o ) - RecordDotSyntaxFail6.hs:10:17: +RecordDotSyntaxFail6.hs:10:17: error: Fields cannot be qualified when OverloadedRecordUpdate is enabled diff --git a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr index feee41589f..0b0cfcc03a 100644 --- a/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr +++ b/testsuite/tests/parser/should_fail/RecordDotSyntaxFail7.stderr @@ -1,4 +1,4 @@ -[1 of 2] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) -[2 of 2] Compiling Main ( RecordDotSyntaxFail7.hs, RecordDotSyntaxFail7.o ) +[1 of 3] Compiling RecordDotSyntaxA ( RecordDotSyntaxA.hs, RecordDotSyntaxA.o ) +[2 of 3] Compiling Main ( RecordDotSyntaxFail7.hs, RecordDotSyntaxFail7.o ) -RecordDotSyntaxFail7.hs:9:16: parse error on input ‘A.foo’ +RecordDotSyntaxFail7.hs:9:16: error: parse error on input ‘A.foo’ diff --git a/testsuite/tests/perf/compiler/Makefile b/testsuite/tests/perf/compiler/Makefile index 20f5704450..0011c70710 100644 --- a/testsuite/tests/perf/compiler/Makefile +++ b/testsuite/tests/perf/compiler/Makefile @@ -16,3 +16,15 @@ T11068: MultiModulesRecomp: ./genMultiLayerModules '$(TEST_HC)' $(TEST_HC_OPTS) -v0 MultiLayerModules.hs + +MultiComponentModulesRecomp: + '$(PYTHON)' genMultiComp.py + TEST_HC='$(TEST_HC)' TEST_HC_OPTS='$(TEST_HC_OPTS)' ./run + +MultiLayerModulesTH_Make_Prep: + ./genMultiLayerModulesTH + "$(TEST_HC)" $(TEST_HC_OPTS) MultiLayerModulesPrep -dynamic-too -v0 + +MultiLayerModulesTH_OneShot_Prep: MultiLayerModulesTH_Make_Prep + $(CP) MultiLayerModules.hs MultiLayerModulesTH_OneShot.hs + diff --git a/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr b/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr new file mode 100644 index 0000000000..4a1b876638 --- /dev/null +++ b/testsuite/tests/perf/compiler/MultiLayerModulesTH_Make.stderr @@ -0,0 +1,8 @@ + +MultiLayerModules.hs:334:8: error: + • Exception when trying to run compile-time code: + deliberate error +CallStack (from HasCallStack): + error, called at MultiLayerModules.hs:334:10 in main:MultiLayerModules + Code: (error "deliberate error") + • In the untyped splice: $(error "deliberate error") diff --git a/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr b/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr new file mode 100644 index 0000000000..a958aceeea --- /dev/null +++ b/testsuite/tests/perf/compiler/MultiLayerModulesTH_OneShot.stderr @@ -0,0 +1,8 @@ + +MultiLayerModulesTH_OneShot.hs:334:8: error: + • Exception when trying to run compile-time code: + deliberate error +CallStack (from HasCallStack): + error, called at MultiLayerModulesTH_OneShot.hs:334:10 in main:MultiLayerModules + Code: (error "deliberate error") + • In the untyped splice: $(error "deliberate error") diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 2f52209d06..25672bf7e7 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -293,6 +293,29 @@ test('MultiLayerModulesRecomp', multimod_compile, ['MultiLayerModules', '-v0']) + +# A performance test for calculating link dependencies in --make mode. +test('MultiLayerModulesTH_Make', + [ collect_compiler_stats('bytes allocated',3), + pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_Make_Prep'), + extra_files(['genMultiLayerModulesTH']), + unless(have_dynamic(),skip), + compile_timeout_multiplier(5) + ], + multimod_compile_fail, + ['MultiLayerModules', '-v0']) + +# A performance test for calculating link dependencies in -c mode. +test('MultiLayerModulesTH_OneShot', + [ collect_compiler_stats('bytes allocated',3), + pre_cmd('$MAKE -s --no-print-directory MultiLayerModulesTH_OneShot_Prep'), + extra_files(['genMultiLayerModulesTH']), + unless(have_dynamic(),skip), + compile_timeout_multiplier(5) + ], + compile_fail, + ['-v0']) + test('MultiLayerModulesDefsGhci', [ collect_compiler_residency(15), pre_cmd('./genMultiLayerModulesDefs'), @@ -319,6 +342,24 @@ test('MultiLayerModulesNoCode', ghci_script, ['MultiLayerModulesNoCode.script']) +test('MultiComponentModulesRecomp', + [ collect_compiler_stats('bytes allocated', 2), + pre_cmd('$MAKE -s --no-print-directory MultiComponentModulesRecomp'), + extra_files(['genMultiComp.py']), + compile_timeout_multiplier(5) + ], + multiunit_compile, + [['unitp%d' % n for n in range(20)], '-fno-code -fwrite-interface -v0']) + +test('MultiComponentModules', + [ collect_compiler_stats('bytes allocated', 2), + pre_cmd('$PYTHON ./genMultiComp.py'), + extra_files(['genMultiComp.py']), + compile_timeout_multiplier(5) + ], + multiunit_compile, + [['unitp%d' % n for n in range(20)], '-fno-code -fwrite-interface -v0']) + test('ManyConstructors', [ collect_compiler_stats('bytes allocated',2), pre_cmd('./genManyConstructors'), diff --git a/testsuite/tests/perf/compiler/genMultiComp.py b/testsuite/tests/perf/compiler/genMultiComp.py new file mode 100755 index 0000000000..d069f77959 --- /dev/null +++ b/testsuite/tests/perf/compiler/genMultiComp.py @@ -0,0 +1,78 @@ +#! /usr/bin/env python + +# Generates a set of interdependent units for testing any obvious performance cliffs +# with multiple component support. +# The structure of each unit is: +# * A Top module, which imports the rest of the modules in the unit +# * A number of modules names Mod_<pid>_<mid>, each module imports all the top +# modules beneath it, and all the modules in the current unit beneath it. + +import os +import stat + +modules_per = 20 +packages = 20 +total = modules_per * packages + +def unit_dir(p): + return "p" + str(p) + +def unit_fname(p): + return "unitp" + str(p) + +def top_fname(p): + return "Top" + str(p) + +def mod_name(p, k): + return "Mod_%d_%d" % (p, k) + +def flatten(t): + return [item for sublist in t for item in sublist] + +def mk_unit_file(p): + fname = top_fname(p) + deps = flatten([["-package-id", unit_dir(k)] for k in range(p)]) + opts = ["-working-dir", unit_dir(p), "-this-unit-id", unit_dir(p), fname] + deps + with open(unit_fname(p), 'w') as fout: + fout.write(' '.join(opts)) + +def mk_top_mod(p): + pdir = unit_dir(p) + topfname = os.path.join(pdir, top_fname(p) + '.hs') + header = 'module %s where' % top_fname(p) + imports = ['import %s' % mod_name(p, m) for m in range(modules_per)] + with open(topfname, 'w') as fout: + fout.write(header + '\n') + fout.write('\n'.join(imports)) + +def mk_mod(p, k): + pdir = unit_dir(p) + fname = os.path.join(pdir, mod_name(p, k) + '.hs') + header = 'module %s where' % mod_name(p,k) + imports1 = ['import ' + top_fname(pn) for pn in range(p)] + imports2 = ['import ' + mod_name(p, kn) for kn in range(k)] + with open(fname, 'w') as fout: + fout.write(header + '\n') + fout.write('\n'.join(imports1)) + fout.write('\n') + fout.write('\n'.join(imports2)) + +def mk_run(): + all_units = flatten([['-unit', '@'+unit_fname(pn)] for pn in range(packages)]) + with open('run', 'w') as fout: + fout.write("$TEST_HC $TEST_HC_OPTS -fno-code -fwrite-interface ") + fout.write(" ".join(all_units)) + + st = os.stat('run') + os.chmod('run', st.st_mode | stat.S_IEXEC) + + +for p in range(packages): + os.mkdir(unit_dir(p)) + mk_unit_file(p) + mk_top_mod(p) + for k in range(modules_per): + mk_mod(p, k) +mk_run() + + diff --git a/testsuite/tests/perf/compiler/genMultiLayerModulesTH b/testsuite/tests/perf/compiler/genMultiLayerModulesTH new file mode 100755 index 0000000000..2781871fa6 --- /dev/null +++ b/testsuite/tests/perf/compiler/genMultiLayerModulesTH @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +# Generate $DEPTH layers of modules with $WIDTH modules on each layer +# Every module on layer N imports all the modules on layer N-1 +# MultiLayerModulesPrep.hs imports all the modules from the last layer, is used to +# prepare all dependencies. +# MultiLayerModules.hs imports all the modules from the last layer, and has NDEFS*WIDTH +# top-level splices which stress some inefficient parts of link dependency calculation. +# Lastly there is a splice which contains an error so that we don't benchmark code +# generation as well. + +DEPTH=10 +WIDTH=30 +NDEFS=10 +for i in $(seq -w 1 $WIDTH); do + echo "module DummyLevel0M$i where" > DummyLevel0M$i.hs; +done +for l in $(seq 1 $DEPTH); do + for i in $(seq -w 1 $WIDTH); do + echo "module DummyLevel${l}M$i where" > DummyLevel${l}M$i.hs; + for j in $(seq -w 1 $WIDTH); do + echo "import DummyLevel$((l-1))M$j" >> DummyLevel${l}M$i.hs; + done + echo "def_${l}_${i} :: Int" >> DummyLevel${l}M$i.hs; + echo "def_${l}_${i} = ${l} * ${i}" >> DummyLevel${l}M${i}.hs; + done +done +# Gen the prep module, which can be compiled without running and TH splices +# but forces the rest of the project to be built. +echo "module MultiLayerModulesPrep where" > MultiLayerModulesPrep.hs +for j in $(seq -w 1 $WIDTH); do + echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModulesPrep.hs; +done + +echo "{-# LANGUAGE TemplateHaskell #-}" > MultiLayerModules.hs +echo "module MultiLayerModules where" >> MultiLayerModules.hs +echo "import Language.Haskell.TH.Syntax" >> MultiLayerModules.hs +for j in $(seq -w 1 $WIDTH); do + echo "import DummyLevel${DEPTH}M$j" >> MultiLayerModules.hs; +done +for j in $(seq -w 1 $WIDTH); do + for i in $(seq -w 1 $NDEFS); do + echo "defth_${j}_${i} = \$(lift def_${DEPTH}_${j})" >> MultiLayerModules.hs; + done +done +# Finally, a splice with an error so we stop before doing code generation +# This +echo "last = \$(error \"deliberate error\")" >> MultiLayerModules.hs diff --git a/testsuite/tests/plugins/frontend01.stdout b/testsuite/tests/plugins/frontend01.stdout index 234c91c10b..8f1c7691f5 100644 --- a/testsuite/tests/plugins/frontend01.stdout +++ b/testsuite/tests/plugins/frontend01.stdout @@ -1,4 +1,4 @@ ["foo","bar"] -[1 of 1] Compiling Main ( frontend01.hs, frontend01.o ) -Linking frontend01 ... +[1 of 2] Compiling Main ( frontend01.hs, frontend01.o ) +[2 of 2] Linking frontend01 hello world diff --git a/testsuite/tests/plugins/plugin-recomp-flags.stdout b/testsuite/tests/plugins/plugin-recomp-flags.stdout index 342fa3e0f8..da1538dd07 100644 --- a/testsuite/tests/plugins/plugin-recomp-flags.stdout +++ b/testsuite/tests/plugins/plugin-recomp-flags.stdout @@ -1,4 +1,4 @@ -[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) -Linking plugin-recomp-test ... -[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Plugin fingerprint changed] -Linking plugin-recomp-test ... +[1 of 2] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) +[2 of 2] Linking plugin-recomp-test +[1 of 2] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Plugin fingerprint changed] +[2 of 2] Linking plugin-recomp-test [Objects changed] diff --git a/testsuite/tests/plugins/plugin-recomp-impure.stdout b/testsuite/tests/plugins/plugin-recomp-impure.stdout index 4a2c0aded6..8703e04dff 100644 --- a/testsuite/tests/plugins/plugin-recomp-impure.stdout +++ b/testsuite/tests/plugins/plugin-recomp-impure.stdout @@ -1,4 +1,4 @@ -[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) -Linking plugin-recomp-test ... -[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Impure plugin forced recompilation] -Linking plugin-recomp-test ... +[1 of 2] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) +[2 of 2] Linking plugin-recomp-test +[1 of 2] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) [Impure plugin forced recompilation] +[2 of 2] Linking plugin-recomp-test [Objects changed] diff --git a/testsuite/tests/plugins/plugin-recomp-pure.stdout b/testsuite/tests/plugins/plugin-recomp-pure.stdout index a6828318a0..80f8d17697 100644 --- a/testsuite/tests/plugins/plugin-recomp-pure.stdout +++ b/testsuite/tests/plugins/plugin-recomp-pure.stdout @@ -1,2 +1,2 @@ -[1 of 1] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) -Linking plugin-recomp-test ... +[1 of 2] Compiling Main ( plugin-recomp-test.hs, plugin-recomp-test.o ) +[2 of 2] Linking plugin-recomp-test diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index b005982d2d..8e9721ec2e 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -51,6 +51,8 @@ import GHC.Utils.Outputable import GHC.Types.Basic import GHC.Unit.Home import GHC.Unit.Finder +import GHC.Unit.Env +import GHC.Unit.Home.ModInfo import GHC.Driver.Config.Finder import GHC.Data.Stream as Stream (collect, yield) diff --git a/testsuite/tests/rts/T9405.stdout b/testsuite/tests/rts/T9405.stdout index a62f1c2d1b..5bec5f7b4f 100644 --- a/testsuite/tests/rts/T9405.stdout +++ b/testsuite/tests/rts/T9405.stdout @@ -1,3 +1,3 @@ -[1 of 1] Compiling Main ( T9405.hs, T9405.o ) -Linking T9405 ... +[1 of 2] Compiling Main ( T9405.hs, T9405.o ) +[2 of 2] Linking T9405 Ticky-Ticky diff --git a/testsuite/tests/rts/linker/linker_unload.stdout b/testsuite/tests/rts/linker/linker_unload.stdout index 84697b99ba..6ae361269f 100644 --- a/testsuite/tests/rts/linker/linker_unload.stdout +++ b/testsuite/tests/rts/linker/linker_unload.stdout @@ -1,3 +1,3 @@ -[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) -Linking linker_unload ... +[1 of 2] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) +[2 of 2] Linking linker_unload 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999
\ No newline at end of file diff --git a/testsuite/tests/rts/linker/linker_unload_native.stdout b/testsuite/tests/rts/linker/linker_unload_native.stdout index 6f6f0acf60..cfe18775cd 100644 --- a/testsuite/tests/rts/linker/linker_unload_native.stdout +++ b/testsuite/tests/rts/linker/linker_unload_native.stdout @@ -1,3 +1,3 @@ -[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) -Linking linker_unload_native ... +[1 of 2] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) +[2 of 2] Linking linker_unload_native 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999
\ No newline at end of file diff --git a/testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout b/testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout index 82f7a2f36d..29b878d591 100644 --- a/testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout +++ b/testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout @@ -1,2 +1,2 @@ -[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) -Linking linker_unload_multiple_objs ... +[1 of 2] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o ) +[2 of 2] Linking linker_unload_multiple_objs diff --git a/testsuite/tests/safeHaskell/check/Check04.stderr b/testsuite/tests/safeHaskell/check/Check04.stderr index ec3bdb1585..78d206a936 100644 --- a/testsuite/tests/safeHaskell/check/Check04.stderr +++ b/testsuite/tests/safeHaskell/check/Check04.stderr @@ -1,2 +1,2 @@ -[4 of 4] Compiling Main ( Check04.hs, Check04.o ) -Linking Check04 ... +[4 of 5] Compiling Main ( Check04.hs, Check04.o ) +[5 of 5] Linking Check04 diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr index 00181efaed..33cb566987 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafe03.stderr @@ -1,4 +1,4 @@ -[2 of 2] Compiling Main ( ImpSafe03.hs, ImpSafe03.o ) +[2 of 3] Compiling Main ( ImpSafe03.hs, ImpSafe03.o ) <no location info>: error: - The package (bytestring-0.10.8.1) is required to be trusted but it isn't! + The package (bytestring-0.11.1.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr index 26f04624af..d058bb2599 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr @@ -1,6 +1,6 @@ -[1 of 3] Compiling SafeLang10_A ( SafeLang10_A.hs, SafeLang10_A.o ) -[2 of 3] Compiling SafeLang10_B ( SafeLang10_B.hs, SafeLang10_B.o ) -[3 of 3] Compiling Main ( SafeLang10.hs, SafeLang10.o ) +[1 of 4] Compiling SafeLang10_A ( SafeLang10_A.hs, SafeLang10_A.o ) +[2 of 4] Compiling SafeLang10_B ( SafeLang10_B.hs, SafeLang10_B.o ) +[3 of 4] Compiling Main ( SafeLang10.hs, SafeLang10.o ) SafeLang10.hs:9:13: error: • Unsafe overlapping instances for Pos [Int] diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr index 33bf7ce3fe..2239f73d8f 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12.stderr @@ -4,9 +4,9 @@ SafeLang12.hs:3:14: warning: SafeLang12_B.hs:3:14: warning: -XTemplateHaskell is not allowed in Safe Haskell; ignoring -XTemplateHaskell -[1 of 3] Compiling SafeLang12_A ( SafeLang12_A.hs, SafeLang12_A.o ) -[2 of 3] Compiling SafeLang12_B ( SafeLang12_B.hs, SafeLang12_B.o ) -[3 of 3] Compiling Main ( SafeLang12.hs, SafeLang12.o ) +[1 of 4] Compiling SafeLang12_A ( SafeLang12_A.hs, SafeLang12_A.o ) +[2 of 4] Compiling SafeLang12_B ( SafeLang12_B.hs, SafeLang12_B.o ) +[3 of 4] Compiling Main ( SafeLang12.hs, SafeLang12.o ) SafeLang12.hs:1:1: error: Top-level splices are not permitted without TemplateHaskell diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr index 1aab52a646..111d0fd19c 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr @@ -1,6 +1,6 @@ -[1 of 3] Compiling SafeLang17_A ( SafeLang17_A.hs, SafeLang17_A.o ) -[2 of 3] Compiling SafeLang17_B ( SafeLang17_B.hs, SafeLang17_B.o ) -[3 of 3] Compiling Main ( SafeLang17.hs, SafeLang17.o ) +[1 of 4] Compiling SafeLang17_A ( SafeLang17_A.hs, SafeLang17_A.o ) +[2 of 4] Compiling SafeLang17_B ( SafeLang17_B.hs, SafeLang17_B.o ) +[3 of 4] Compiling Main ( SafeLang17.hs, SafeLang17.o ) SafeLang17.hs:9:13: error: • Unsafe overlapping instances for Pos [Int] diff --git a/testsuite/tests/tcplugins/TcPlugin_RewritePerf.stderr b/testsuite/tests/tcplugins/TcPlugin_RewritePerf.stderr index 1600c377f6..1213844c57 100644 --- a/testsuite/tests/tcplugins/TcPlugin_RewritePerf.stderr +++ b/testsuite/tests/tcplugins/TcPlugin_RewritePerf.stderr @@ -1,6 +1,6 @@ -[1 of 3] Compiling RewritePerfDefs ( RewritePerfDefs.hs, RewritePerfDefs.o ) -[2 of 3] Compiling RewritePerfPlugin ( RewritePerfPlugin.hs, RewritePerfPlugin.o ) -[3 of 3] Compiling Main ( TcPlugin_RewritePerf.hs, TcPlugin_RewritePerf.o ) +[1 of 4] Compiling RewritePerfDefs ( RewritePerfDefs.hs, RewritePerfDefs.o ) +[2 of 4] Compiling RewritePerfPlugin ( RewritePerfPlugin.hs, RewritePerfPlugin.o ) +[3 of 4] Compiling Main ( TcPlugin_RewritePerf.hs, TcPlugin_RewritePerf.o ) TcPlugin_RewritePerf.hs:25:8: error: • No instance for (Show diff --git a/testsuite/tests/th/TH_linker/path_with_commas.stdout b/testsuite/tests/th/TH_linker/path_with_commas.stdout index 0621c2410a..9559dcdc64 100644 --- a/testsuite/tests/th/TH_linker/path_with_commas.stdout +++ b/testsuite/tests/th/TH_linker/path_with_commas.stdout @@ -1,4 +1,4 @@ Reading package info from "test.pkg" ... done. -[1 of 1] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[1 of 2] Compiling Main ( Main.hs, Main.o ) +[2 of 2] Linking Main hello diff --git a/testsuite/tests/typecheck/should_fail/T13068.stderr b/testsuite/tests/typecheck/should_fail/T13068.stderr index 6ecf1871c6..d78e402f76 100644 --- a/testsuite/tests/typecheck/should_fail/T13068.stderr +++ b/testsuite/tests/typecheck/should_fail/T13068.stderr @@ -1,5 +1,5 @@ -[1 of 4] Compiling T13068[boot] ( T13068.hs-boot, T13068.o-boot ) -[2 of 4] Compiling T13068a ( T13068a.hs, T13068a.o ) +[1 of 5] Compiling T13068[boot] ( T13068.hs-boot, T13068.o-boot ) +[2 of 5] Compiling T13068a ( T13068a.hs, T13068a.o ) T13068a.hs:3:10: error: • Cannot define instance for abstract class ‘C’ diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr index 78a92e7d1b..ed1a8c3de2 100644 --- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -1,8 +1,8 @@ -[1 of 5] Compiling T6018Afail ( T6018Afail.hs, T6018Afail.o ) -[2 of 5] Compiling T6018Bfail ( T6018Bfail.hs, T6018Bfail.o ) -[3 of 5] Compiling T6018Cfail ( T6018Cfail.hs, T6018Cfail.o ) -[4 of 5] Compiling T6018Dfail ( T6018Dfail.hs, T6018Dfail.o ) -[5 of 5] Compiling T6018fail ( T6018fail.hs, T6018fail.o ) +[1 of 6] Compiling T6018Afail ( T6018Afail.hs, T6018Afail.o ) +[2 of 6] Compiling T6018Bfail ( T6018Bfail.hs, T6018Bfail.o ) +[3 of 6] Compiling T6018Cfail ( T6018Cfail.hs, T6018Cfail.o ) +[4 of 6] Compiling T6018Dfail ( T6018Dfail.hs, T6018Dfail.o ) +[5 of 6] Compiling T6018fail ( T6018fail.hs, T6018fail.o ) T6018fail.hs:15:15: error: Type family equation right-hand sides overlap; this violates diff --git a/testsuite/tests/unboxedsums/module/sum_mod.stdout b/testsuite/tests/unboxedsums/module/sum_mod.stdout index 615266b7f6..bf322a1137 100644 --- a/testsuite/tests/unboxedsums/module/sum_mod.stdout +++ b/testsuite/tests/unboxedsums/module/sum_mod.stdout @@ -1,3 +1,3 @@ -[2 of 2] Compiling Main ( Main.hs, Main.o ) -Linking Main ... +[2 of 3] Compiling Main ( Main.hs, Main.o ) +[3 of 3] Linking Main 123 diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727a.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727a.stderr index c77fbc4300..383b6df7bd 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727a.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727a.stderr @@ -1,6 +1,7 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 -[1 of 2] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 2] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -Linking src-exe/Main ... + Modules are not listed in command line but needed for compilation: + M1 +[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 3] Linking src-exe/Main diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727b.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727b.stderr index c77fbc4300..383b6df7bd 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727b.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727b.stderr @@ -1,6 +1,7 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 -[1 of 2] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 2] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -Linking src-exe/Main ... + Modules are not listed in command line but needed for compilation: + M1 +[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 3] Linking src-exe/Main diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727c.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727c.stderr index 0b9ac0ebf2..c9c968ddf3 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727c.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727c.stderr @@ -1,3 +1,3 @@ -[1 of 2] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 2] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -Linking src-exe/Main ... +[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 3] Linking src-exe/Main diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727d.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727d.stderr index 0b9ac0ebf2..c9c968ddf3 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727d.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727d.stderr @@ -1,3 +1,3 @@ -[1 of 2] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 2] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -Linking src-exe/Main ... +[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 3] Linking src-exe/Main diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727e.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727e.stderr index 0b9ac0ebf2..c9c968ddf3 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727e.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727e.stderr @@ -1,3 +1,3 @@ -[1 of 2] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 2] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -Linking src-exe/Main ... +[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 3] Linking src-exe/Main diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727f.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727f.stderr index 20a42baeb9..9d084b94f6 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727f.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727f.stderr @@ -1,8 +1,8 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 - Main -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... + Modules are not listed in command line but needed for compilation: + M1 Main +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727g.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727g.stderr index 20a42baeb9..9d084b94f6 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727g.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727g.stderr @@ -1,8 +1,8 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 - Main -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... + Modules are not listed in command line but needed for compilation: + M1 Main +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727h.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727h.stderr index a29f764a47..b627f7eaf5 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727h.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727h.stderr @@ -1,7 +1,8 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... + Modules are not listed in command line but needed for compilation: + M1 +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727i.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727i.stderr index a29f764a47..b627f7eaf5 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727i.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727i.stderr @@ -1,7 +1,8 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: M1 -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... + Modules are not listed in command line but needed for compilation: + M1 +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727j.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727j.stderr index e85f778a56..685860db43 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727j.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727j.stderr @@ -1,7 +1,8 @@ <no location info>: warning: [-Wmissing-home-modules] - Modules are not listed in command line but needed for compilation: Main -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... + Modules are not listed in command line but needed for compilation: + Main +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/T13727/T13727k.stderr b/testsuite/tests/warnings/should_compile/T13727/T13727k.stderr index c648d9b593..3cfcf4bcac 100644 --- a/testsuite/tests/warnings/should_compile/T13727/T13727k.stderr +++ b/testsuite/tests/warnings/should_compile/T13727/T13727k.stderr @@ -1,4 +1,4 @@ -[1 of 3] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) -[2 of 3] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) -[3 of 3] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) -Linking src-exe/AltMain ... +[1 of 4] Compiling M1 ( src-lib/M1.hs, src-lib/M1.o ) +[2 of 4] Compiling Main ( src-exe/Main.hs, src-exe/Main.o ) +[3 of 4] Compiling AltMain ( src-exe/AltMain.hs, src-exe/AltMain.o ) +[4 of 4] Linking src-exe/AltMain diff --git a/testsuite/tests/warnings/should_compile/UnusedPackages.stderr b/testsuite/tests/warnings/should_compile/UnusedPackages.stderr index ba6a76207f..11f87e6de4 100644 --- a/testsuite/tests/warnings/should_compile/UnusedPackages.stderr +++ b/testsuite/tests/warnings/should_compile/UnusedPackages.stderr @@ -5,5 +5,5 @@ - ghc - process - bytestring -[1 of 1] Compiling Main ( UnusedPackages.hs, UnusedPackages.o ) -Linking UnusedPackages ... +[1 of 2] Compiling Main ( UnusedPackages.hs, UnusedPackages.o ) +[2 of 2] Linking UnusedPackages diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index 0848b9d485..47b3fe3bbf 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -9,10 +9,10 @@ import Control.Monad.IO.Class import GHC.Types.SrcLoc import GHC hiding (moduleName) import GHC.Hs.Dump +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Make -import GHC.Unit.Module.ModSummary import GHC.Utils.Outputable hiding (space) import System.Environment( getArgs ) import System.Exit @@ -85,10 +85,10 @@ parseOneFile libdir fileName = do let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream _ <- setSessionDynFlags dflags2 hsc_env <- getSession - ms <- liftIO $ summariseFile hsc_env [] fileName Nothing Nothing - case ms of + mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) mempty fileName Nothing Nothing + case mms of Left _err -> error "parseOneFile" - Right ems -> parseModule (emsModSummary ems) + Right ms -> parseModule ms getPragmas :: Located HsModule -> String getPragmas (L _ (HsModule { hsmodAnn = anns'})) = pragmaStr diff --git a/utils/count-deps/Main.hs b/utils/count-deps/Main.hs index fc37ac555b..9dcc75619d 100644 --- a/utils/count-deps/Main.hs +++ b/utils/count-deps/Main.hs @@ -78,4 +78,4 @@ calcDeps modName libdir = mkModule = Module (stringToUnit "ghc") modDeps :: ModIface -> [ModuleName] - modDeps mi = map gwib_mod $ Set.toList $ dep_direct_mods (mi_deps mi) + modDeps mi = map (gwib_mod . snd) $ Set.toList $ dep_direct_mods (mi_deps mi) diff --git a/utils/haddock b/utils/haddock -Subproject 00e7d92f372c706dfd749d824c8c97d38383c25 +Subproject 5d14361971ec6e6c3dfca282e4b80b307087afe |