Move Unit related fields from DynFlags to HscEnv

The unit database cache, the home unit and the unit state were stored in
DynFlags while they ought to be stored in the compiler session state
(HscEnv). This patch fixes this.

It introduces a new UnitEnv type that should be used in the future to
handle separate unit environments (especially host vs target units).

Related to #17957

Bump haddock submodule

1 files changed, 125 insertions, 148 deletions

diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs
index 74ba55a702..1aabfb10c2 100644
--- a/compiler/GHC/Unit/State.hs
+++ b/compiler/GHC/Unit/State.hs
@@ -1,6 +1,7 @@
 -- (c) The University of Glasgow, 2006
 
 {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- | Unit manipulation
 module GHC.Unit.State (
@@ -9,6 +10,7 @@ module GHC.Unit.State (
         -- * Reading the package config, and processing cmdline args
         UnitState(..),
         UnitDatabase (..),
+        UnitErr (..),
         emptyUnitState,
         initUnits,
         readUnitDatabases,
@@ -39,12 +41,9 @@ module GHC.Unit.State (
         UnusableUnitReason(..),
         pprReason,
 
-        -- * Inspecting the set of packages in scope
-        getUnitIncludePath,
-        getUnitExtraCcOpts,
-        getPreloadUnitsAnd,
-
-        collectIncludeDirs,
+        closeUnitDeps,
+        closeUnitDeps',
+        mayThrowUnitErr,
 
         -- * Module hole substitution
         ShHoleSubst,
@@ -73,19 +72,23 @@ where
 
 import GHC.Prelude
 
+import GHC.Driver.Session
+
 import GHC.Platform
-import GHC.Unit.Home
+import GHC.Platform.Ways
+
 import GHC.Unit.Database
 import GHC.Unit.Info
 import GHC.Unit.Ppr
 import GHC.Unit.Types
 import GHC.Unit.Module
-import GHC.Driver.Session
-import GHC.Platform.Ways
+import GHC.Unit.Home
+
 import GHC.Types.Unique.FM
 import GHC.Types.Unique.DFM
 import GHC.Types.Unique.Set
 import GHC.Types.Unique.DSet
+
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Outputable as Outputable
@@ -94,7 +97,7 @@ import GHC.Data.Maybe
 import System.Environment ( getEnv )
 import GHC.Data.FastString
 import qualified GHC.Data.ShortText as ST
-import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,
+import GHC.Utils.Error  ( debugTraceMsg, dumpIfSet_dyn,
                           withTiming, DumpFormat (..) )
 import GHC.Utils.Exception
 
@@ -342,8 +345,8 @@ data UnitConfig = UnitConfig
    , unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units
    }
 
-initUnitConfig :: DynFlags -> UnitConfig
-initUnitConfig dflags =
+initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig
+initUnitConfig dflags cached_dbs =
    let !hu_id             = homeUnitId_ dflags
        !hu_instanceof     = homeUnitInstanceOf_ dflags
        !hu_instantiations = homeUnitInstantiations_ dflags
@@ -376,7 +379,7 @@ initUnitConfig dflags =
       , unitConfigHideAll        = gopt Opt_HideAllPackages dflags
       , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags
 
-      , unitConfigDBCache      = unitDatabases dflags
+      , unitConfigDBCache      = cached_dbs
       , unitConfigFlagsDB      = packageDBFlags dflags
       , unitConfigFlagsExposed = packageFlags dflags
       , unitConfigFlagsIgnored = ignorePackageFlags dflags
@@ -573,27 +576,55 @@ 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 :: DynFlags -> IO DynFlags
-initUnits dflags = do
+initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit)
+initUnits dflags cached_dbs = do
 
   let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
   let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages
   let printer = debugTraceMsg dflags                    -- printer for trace messages
 
-  (state,dbs) <- withTiming dflags (text "initializing unit database")
+  (unit_state,dbs) <- withTiming dflags (text "initializing unit database")
                    forceUnitInfoMap
-                   (mkUnitState ctx printer (initUnitConfig dflags))
-
-  dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map"
-    FormatText (pprModuleMap (moduleNameProvidersMap state))
-
-  let dflags'  = dflags
-                  { unitDatabases = Just dbs -- databases are cached and never read again
-                  , unitState     = state
-                  }
-      dflags'' = upd_wired_in_home_instantiations dflags'
-
-  return dflags''
+                 $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs)
+
+  dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map"
+    FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
+                $ pprModuleMap (moduleNameProvidersMap unit_state))
+
+  let home_unit = mkHomeUnit unit_state
+                             (homeUnitId_ dflags)
+                             (homeUnitInstanceOf_ dflags)
+                             (homeUnitInstantiations_ dflags)
+
+  return (dbs,unit_state,home_unit)
+
+mkHomeUnit
+    :: UnitState
+    -> UnitId                 -- ^ Home unit id
+    -> Maybe UnitId           -- ^ Home unit instance of
+    -> [(ModuleName, Module)] -- ^ Home unit instantiations
+    -> HomeUnit
+mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =
+    let
+        -- Some wired units can be used to instantiate the home unit. We need to
+        -- replace their unit keys with their wired unit ids.
+        wmap              = wireMap unit_state
+        hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_
+    in case (hu_instanceof, hu_instantiations) of
+      (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing
+      (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")
+      (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")
+      (Just u, is)
+         -- detect fully indefinite units: all their instantiations are hole
+         -- modules and the home unit id is the same as the instantiating unit
+         -- id (see Note [About units] in GHC.Unit)
+         | all (isHoleModule . snd) is && u == hu_id
+         -> IndefiniteHomeUnit u is
+         -- otherwise it must be that we (fully) instantiate an indefinite unit
+         -- to make it definite.
+         -- TODO: error when the unit is partially instantiated??
+         | otherwise
+         -> DefiniteHomeUnit hu_id (Just (u, is))
 
 -- -----------------------------------------------------------------------------
 -- Reading the unit database(s)
@@ -759,30 +790,28 @@ mungeDynLibFields pkg =
 -- -trust and -distrust.
 
 applyTrustFlag
-   :: SDocContext
-   -> UnitPrecedenceMap
+   :: UnitPrecedenceMap
    -> UnusableUnits
    -> [UnitInfo]
    -> TrustFlag
-   -> IO [UnitInfo]
-applyTrustFlag ctx prec_map unusable pkgs flag =
+   -> MaybeErr UnitErr [UnitInfo]
+applyTrustFlag prec_map unusable pkgs flag =
   case flag of
     -- we trust all matching packages. Maybe should only trust first one?
     -- and leave others the same or set them untrusted
     TrustPackage str ->
        case selectPackages prec_map (PackageArg str) pkgs unusable of
-         Left ps       -> trustFlagErr ctx flag ps
-         Right (ps,qs) -> return (map trust ps ++ qs)
+         Left ps       -> Failed (TrustFlagErr flag ps)
+         Right (ps,qs) -> Succeeded (map trust ps ++ qs)
           where trust p = p {unitIsTrusted=True}
 
     DistrustPackage str ->
        case selectPackages prec_map (PackageArg str) pkgs unusable of
-         Left ps       -> trustFlagErr ctx flag ps
-         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)
+         Left ps       -> Failed (TrustFlagErr flag ps)
+         Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)
 
 applyPackageFlag
-   :: SDocContext
-   -> UnitPrecedenceMap
+   :: UnitPrecedenceMap
    -> UnitInfoMap
    -> PreloadUnitClosure
    -> UnusableUnits
@@ -790,15 +819,15 @@ applyPackageFlag
            -- any previously exposed packages with the same name
    -> [UnitInfo]
    -> VisibilityMap           -- Initially exposed
-   -> PackageFlag               -- flag to apply
-   -> IO VisibilityMap        -- Now exposed
+   -> PackageFlag             -- flag to apply
+   -> MaybeErr UnitErr VisibilityMap -- Now exposed
 
-applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
+applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =
   case flag of
     ExposePackage _ arg (ModRenaming b rns) ->
        case findPackages prec_map pkg_map closure arg pkgs unusable of
-         Left ps         -> packageFlagErr ctx flag ps
-         Right (p:_) -> return vm'
+         Left ps     -> Failed (PackageFlagErr flag ps)
+         Right (p:_) -> Succeeded vm'
           where
            n = fsPackageName p
 
@@ -861,9 +890,8 @@ applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm fl
 
     HidePackage str ->
        case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of
-         Left ps  -> packageFlagErr ctx flag ps
-         Right ps -> return vm'
-          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)
+         Left ps  -> Failed (PackageFlagErr flag ps)
+         Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)
 
 -- | Like 'selectPackages', but doesn't return a list of unmatched
 -- packages.  Furthermore, any packages it returns are *renamed*
@@ -970,34 +998,6 @@ compareByPreference prec_map pkg pkg'
 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 comparing f a b = f a `compare` f b
 
-packageFlagErr :: SDocContext
-               -> PackageFlag
-               -> [(UnitInfo, UnusableUnitReason)]
-               -> IO a
-packageFlagErr ctx flag reasons
-  = packageFlagErr' ctx (pprFlag flag) reasons
-
-trustFlagErr :: SDocContext
-             -> TrustFlag
-             -> [(UnitInfo, UnusableUnitReason)]
-             -> IO a
-trustFlagErr ctx flag reasons
-  = packageFlagErr' ctx (pprTrustFlag flag) reasons
-
-packageFlagErr' :: SDocContext
-               -> SDoc
-               -> [(UnitInfo, UnusableUnitReason)]
-               -> IO a
-packageFlagErr' ctx flag_doc reasons
-  = throwGhcExceptionIO (CmdLineError (renderWithContext ctx $ err))
-  where err = text "cannot satisfy " <> flag_doc <>
-                (if null reasons then Outputable.empty else text ": ") $$
-              nest 4 (ppr_reasons $$
-                      text "(use -v for more information)")
-        ppr_reasons = vcat (map ppr_reason reasons)
-        ppr_reason (p, reason) =
-            pprReason (ppr (unitId p) <+> text "is") reason
-
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
     HidePackage p   -> text "-hide-package " <> text p
@@ -1117,17 +1117,6 @@ findWiredInUnits printer prec_map pkgs vis_map = do
 -- For instance, base-4.9.0.0 will be rewritten to just base, to match
 -- what appears in GHC.Builtin.Names.
 
--- | Some wired units can be used to instantiate the home unit. We need to
--- replace their unit keys with their wired unit ids.
-upd_wired_in_home_instantiations :: DynFlags -> DynFlags
-upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations_ = wiredInsts }
-   where
-      state        = unitState dflags
-      wiringMap    = wireMap state
-      unwiredInsts = homeUnitInstantiations_ dflags
-      wiredInsts   = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts
-
-
 upd_wired_in_mod :: WiringMap -> Module -> Module
 upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
 
@@ -1482,7 +1471,8 @@ mkUnitState ctx printer cfg = do
 
   -- Apply trust flags (these flags apply regardless of whether
   -- or not packages are visible or not)
-  pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable)
+  pkgs1 <- mayThrowUnitErr
+            $ foldM (applyTrustFlag prec_map unusable)
                  (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
   let prelim_pkg_db = mkUnitInfoMap pkgs1
 
@@ -1540,7 +1530,8 @@ mkUnitState ctx printer cfg = do
   -- -hide-package).  This needs to know about the unusable packages, since if a
   -- user tries to enable an unusable package, we should let them know.
   --
-  vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable
+  vis_map2 <- mayThrowUnitErr
+                $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
                         (unitConfigHideAll cfg) pkgs1)
                             vis_map1 other_flags
 
@@ -1568,7 +1559,8 @@ mkUnitState ctx printer cfg = do
                         -- won't work.
                         | otherwise = vis_map2
                 plugin_vis_map2
-                    <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable
+                    <- mayThrowUnitErr
+                        $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
                                 hide_plugin_pkgs pkgs1)
                              plugin_vis_map1
                              (reverse (unitConfigFlagsPlugins cfg))
@@ -1614,8 +1606,9 @@ mkUnitState ctx printer cfg = do
       preload3 = ordNub $ (basicLinkedUnits ++ preload1)
 
   -- Close the preload packages with their dependencies
-  let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing))
-  dep_preload <- throwErr ctx dep_preload_err
+  dep_preload <- mayThrowUnitErr
+                    $ closeUnitDeps pkg_db
+                    $ zip (map toUnitId preload3) (repeat Nothing)
 
   let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map
       mod_map2 = mkUnusableModuleNameProvidersMap unusable
@@ -1635,7 +1628,6 @@ mkUnitState ctx printer cfg = do
          , requirementContext           = req_ctx
          , allowVirtualUnits            = unitConfigAllowVirtual cfg
          }
-
   return (state, raw_dbs)
 
 -- | Given a wired-in 'Unit', "unwire" it into the 'Unit'
@@ -1775,30 +1767,6 @@ addListTo = foldl' merge
 mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
 mkModMap pkg mod = Map.singleton (mkModule pkg mod)
 
--- -----------------------------------------------------------------------------
--- Extracting information from the packages in scope
-
--- Many of these functions take a list of packages: in those cases,
--- the list is expected to contain the "dependent packages",
--- i.e. those packages that were found to be depended on by the
--- current module/program.  These can be auto or non-auto packages, it
--- doesn't really matter.  The list is always combined with the list
--- of preload (command-line) packages to determine which packages to
--- use.
-
--- | Find all the include directories in these and the preload packages
-getUnitIncludePath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
-getUnitIncludePath ctx unit_state home_unit pkgs =
-  collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs
-
-collectIncludeDirs :: [UnitInfo] -> [FilePath]
-collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))
-
--- | Find all the C-compiler options in these and the preload packages
-getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
-getUnitExtraCcOpts ctx unit_state home_unit pkgs = do
-  ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs
-  return $ map ST.unpack (concatMap unitCcOptions ps)
 
 -- -----------------------------------------------------------------------------
 -- Package Utils
@@ -1923,39 +1891,15 @@ listVisibleModuleNames state =
     map fst (filter visible (Map.toList (moduleNameProvidersMap state)))
   where visible (_, ms) = any originVisible (Map.elems ms)
 
--- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit
--- used to instantiate the home unit, and for every unit explicitly passed in
--- the given list of UnitId.
-getPreloadUnitsAnd :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
-getPreloadUnitsAnd ctx unit_state home_unit ids0 =
-  let
-      ids      = ids0 ++ inst_ids
-      inst_ids
-         -- An indefinite package will have insts to HOLE,
-         -- which is not a real package. Don't look it up.
-         -- Fixes #14525
-         | isHomeUnitIndefinite home_unit = []
-         | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)
-      pkg_map = unitInfoMap unit_state
-      preload = preloadUnits unit_state
-  in do
-  all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing))
-  return (map (unsafeLookupUnitId unit_state) all_pkgs)
-
-throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a
-throwErr ctx m = case m of
-   Failed e    -> throwGhcExceptionIO (CmdLineError (renderWithContext ctx e))
-   Succeeded r -> return r
-
 -- | Takes a list of UnitIds (and their "parent" dependency, used for error
 -- messages), and returns the list with dependencies included, in reverse
 -- dependency order (a units appears before those it depends on).
-closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]
+closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
 closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps
 
 -- | Similar to closeUnitDeps but takes a list of already loaded units as an
 -- additional argument.
-closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]
+closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
 closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
 
 -- | Add a UnitId and those it depends on (recursively) to the given list of
@@ -1968,16 +1912,11 @@ closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps
 add_unit :: UnitInfoMap
             -> [UnitId]
             -> (UnitId,Maybe UnitId)
-            -> MaybeErr MsgDoc [UnitId]
+            -> MaybeErr UnitErr [UnitId]
 add_unit pkg_map ps (p, mb_parent)
   | p `elem` ps = return ps     -- Check if we've already added this unit
   | otherwise   = case lookupUnitId' pkg_map p of
-      Nothing -> Failed $
-                   (ftext (fsLit "unknown package:") <+> ppr p)
-                   <> case mb_parent of
-                         Nothing     -> Outputable.empty
-                         Just parent -> space <> parens (text "dependency of"
-                                                  <+> ftext (unitIdFS parent))
+      Nothing   -> Failed (CloseUnitErr p mb_parent)
       Just info -> do
          -- Add the unit's dependents also
          ps' <- foldM add_unit_key ps (unitDepends info)
@@ -1986,6 +1925,44 @@ add_unit pkg_map ps (p, mb_parent)
           add_unit_key ps key
             = add_unit pkg_map ps (key, Just p)
 
+data UnitErr
+  = CloseUnitErr !UnitId !(Maybe UnitId)
+  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
+  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]
+
+mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
+mayThrowUnitErr = \case
+    Failed e    -> throwGhcExceptionIO
+                    $ CmdLineError
+                    $ renderWithContext defaultSDocContext
+                    $ withPprStyle defaultUserStyle
+                    $ ppr e
+    Succeeded a -> return a
+
+instance Outputable UnitErr where
+    ppr = \case
+        CloseUnitErr p mb_parent
+            -> (ftext (fsLit "unknown unit:") <+> ppr p)
+               <> case mb_parent of
+                     Nothing     -> Outputable.empty
+                     Just parent -> space <> parens (text "dependency of"
+                                              <+> ftext (unitIdFS parent))
+        PackageFlagErr flag reasons
+            -> flag_err (pprFlag flag) reasons
+
+        TrustFlagErr flag reasons
+            -> flag_err (pprTrustFlag flag) reasons
+      where
+        flag_err flag_doc reasons =
+            text "cannot satisfy "
+            <> flag_doc
+            <> (if null reasons then Outputable.empty else text ": ")
+            $$ nest 4 (vcat (map ppr_reason reasons) $$
+                      text "(use -v for more information)")
+
+        ppr_reason (p, reason) =
+            pprReason (ppr (unitId p) <+> text "is") reason
+
 -- -----------------------------------------------------------------------------
 
 -- | Pretty-print a UnitId for the user.