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>

1 files changed, 83 insertions, 45 deletions

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)