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

3 files changed, 49 insertions, 36 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 81b0a84fca..152017de38 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1495,7 +1495,8 @@ info allInfo s  = handleSourceError GHC.printException $ do
     unqual <- GHC.getPrintUnqual
     dflags <- getDynFlags
     sdocs  <- mapM (infoThing allInfo) (words s)
-    mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
+    unit_state <- hsc_units <$> GHC.getSession
+    mapM_ (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs
 
 infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
 infoThing allInfo str = do
@@ -1796,7 +1797,8 @@ docCmd s  = do
   let sdocs' = vcat (intersperse (text "") sdocs)
   unqual <- GHC.getPrintUnqual
   dflags <- getDynFlags
-  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'
+  unit_state <- hsc_units <$> GHC.getSession
+  (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs'
 
 pprDocs :: [(Maybe HsDocString, Map Int HsDocString)] -> [SDoc]
 pprDocs docs
@@ -2085,6 +2087,7 @@ keepPackageImports = filterM is_pkg_import
 modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()
 modulesLoadedMsg ok mods = do
   dflags <- getDynFlags
+  unit_state <- hsc_units <$> GHC.getSession
   unqual <- GHC.getPrintUnqual
 
   msg <- if gopt Opt_ShowLoadedModules dflags
@@ -2099,7 +2102,7 @@ modulesLoadedMsg ok mods = do
                     <+> speakNOf (length mods) (text "module") <+> "loaded."
 
   when (verbosity dflags > 0) $
-     liftIO $ putStrLn $ showSDocForUser dflags unqual msg
+     liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual msg
   where
     status = case ok of
                   Failed    -> text "Failed"
@@ -2122,7 +2125,8 @@ runExceptGhcMonad act = handleSourceError GHC.printException $
   where
     handleErr sdoc = do
         dflags <- getDynFlags
-        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
+        unit_state <- hsc_units <$> GHC.getSession
+        liftIO . hPutStrLn stderr . showSDocForUser dflags unit_state alwaysQualify $ sdoc
 
 -- | Inverse of 'runExceptT' for \"pure\" computations
 -- (c.f. 'except' for 'Except')
@@ -2186,9 +2190,11 @@ allTypesCmd _ = runExceptGhcMonad $ do
   where
     printSpan span'
       | Just ty <- spaninfoType span' = do
-        df <- getDynFlags
+        hsc_env <- GHC.getSession
         let tyInfo = unwords . words $
-                     showSDocForUser df alwaysQualify (pprTypeForUser ty)
+                     showSDocForUser (hsc_dflags hsc_env)
+                                     (hsc_units  hsc_env)
+                                     alwaysQualify (pprTypeForUser ty)
         liftIO . putStrLn $
             showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
       | otherwise = return ()
@@ -2357,6 +2363,7 @@ isSafeModule m = do
          (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
 
     dflags <- getDynFlags
+    hsc_env <- GHC.getSession
     let iface = GHC.modInfoIface $ fromJust mb_mod_info
     when (isNothing iface)
          (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
@@ -2364,8 +2371,8 @@ isSafeModule m = do
 
     (msafe, pkgs) <- GHC.moduleTrustReqs m
     let trust  = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
-        pkg    = if packageTrusted dflags m then "trusted" else "untrusted"
-        (good, bad) = tallyPkgs dflags pkgs
+        pkg    = if packageTrusted hsc_env m then "trusted" else "untrusted"
+        (good, bad) = tallyPkgs hsc_env pkgs
 
     -- print info to user...
     liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
@@ -2384,14 +2391,15 @@ isSafeModule m = do
   where
     mname = GHC.moduleNameString $ GHC.moduleName m
 
-    packageTrusted dflags md
-        | isHomeModule (mkHomeUnitFromFlags dflags) md = True
-        | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit md)
+    packageTrusted hsc_env md
+        | isHomeModule (hsc_home_unit hsc_env) md = True
+        | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md)
 
-    tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
+    tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty)
                           | otherwise = S.partition part deps
         where part pkg   = unitIsTrusted $ unsafeLookupUnitId unit_state pkg
-              unit_state = unitState dflags
+              unit_state = hsc_units hsc_env
+              dflags     = hsc_dflags hsc_env
 
 -----------------------------------------------------------------------------
 -- :browse
@@ -2497,7 +2505,8 @@ browseModule bang modl exports_only = do
             prettyThings = map pretty things
             prettyThings' | bang      = annotate $ zip modNames prettyThings
                           | otherwise = prettyThings
-        liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
+        unit_state <- hsc_units <$> GHC.getSession
+        liftIO $ putStrLn $ showSDocForUser dflags unit_state unqual (vcat prettyThings')
         -- ToDo: modInfoInstances currently throws an exception for
         -- package modules.  When it works, we can do this:
         --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
@@ -2971,16 +2980,14 @@ newDynFlags interactive_only minus_opts = do
           -- delete targets and all eventually defined breakpoints. (#1620)
           clearAllTargets
           when must_reload $ do
-            let units = preloadUnits (unitState dflags2)
+            let units = preloadUnits (hsc_units hsc_env)
             liftIO $ Loader.loadPackages hsc_env units
           -- package flags changed, we can't re-use any of the old context
           setContextAfterLoad False []
-          -- and copy the package state to the interactive DynFlags
+          -- and copy the package flags to the interactive DynFlags
           idflags <- GHC.getInteractiveDynFlags
           GHC.setInteractiveDynFlags
-              idflags{ unitState = unitState dflags2
-                     , unitDatabases = unitDatabases dflags2
-                     , packageFlags = packageFlags dflags2 }
+              idflags{ packageFlags = packageFlags dflags2 }
 
         let ld0length   = length $ ldInputs dflags0
             fmrk0length = length $ cmdlineFrameworks dflags0
@@ -3475,23 +3482,23 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
         pure $ map (combineModIdent mod_str) bids
 
 completeModule = wrapIdentCompleter $ \w -> do
-  dflags <- GHC.getSessionDynFlags
-  let pkg_mods = allVisibleModules dflags
+  hsc_env <- GHC.getSession
+  let pkg_mods = allVisibleModules (hsc_units hsc_env)
   loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
   return $ filter (w `isPrefixOf`)
-        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
+        $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
 
 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
-  dflags <- GHC.getSessionDynFlags
+  hsc_env <- GHC.getSession
   modules <- case m of
     Just '-' -> do
       imports <- GHC.getContext
       return $ map iiModuleName imports
     _ -> do
-      let pkg_mods = allVisibleModules dflags
+      let pkg_mods = allVisibleModules (hsc_units hsc_env)
       loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
       return $ loaded_mods ++ pkg_mods
-  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
+  return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
 
 completeHomeModule = wrapIdentCompleter listHomeModules
 
@@ -3549,8 +3556,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
 
 -- | Return a list of visible module names for autocompletion.
 -- (NB: exposed != visible)
-allVisibleModules :: DynFlags -> [ModuleName]
-allVisibleModules dflags = listVisibleModuleNames (unitState dflags)
+allVisibleModules :: UnitState -> [ModuleName]
+allVisibleModules unit_state = listVisibleModuleNames unit_state
 
 completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
                         completeIdentifier
@@ -4335,7 +4342,7 @@ wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
 wantInterpretedModuleName modname = do
    modl <- lookupModuleName modname
    let str = moduleNameString modname
-   home_unit <- mkHomeUnitFromFlags <$> getDynFlags
+   home_unit <- hsc_home_unit <$> GHC.getSession
    unless (isHomeModule home_unit modl) $
       throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
    is_interpreted <- GHC.moduleIsInterpreted modl
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index 64db8ea219..e6cf0838ca 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -40,6 +40,7 @@ import           GHC.Driver.Session (HasDynFlags(..))
 import           GHC.Data.FastString
 import           GHC
 import           GHC.Driver.Monad
+import           GHC.Driver.Env
 import           GHC.Driver.Ppr
 import           GHC.Types.Name
 import           GHC.Types.Name.Set
@@ -264,6 +265,7 @@ collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
                -> m (Map ModuleName ModInfo)
 collectInfo ms loaded = do
     df <- getDynFlags
+    unit_state <- hsc_units <$> getSession
     liftIO (filterM cacheInvalid loaded) >>= \case
         [] -> return ms
         invalidated -> do
@@ -271,13 +273,13 @@ collectInfo ms loaded = do
                               show (length invalidated) ++
                               " module(s) ... "))
 
-            foldM (go df) ms invalidated
+            foldM (go df unit_state) ms invalidated
   where
-    go df m name = do { info <- getModInfo name; return (M.insert name info m) }
+    go df unit_state m name = do { info <- getModInfo name; return (M.insert name info m) }
                    `MC.catch`
                    (\(e :: SomeException) -> do
                          liftIO $ putStrLn
-                                $ showSDocForUser df alwaysQualify
+                                $ showSDocForUser df unit_state alwaysQualify
                                 $ "Error while getting type info from" <+>
                                   ppr name <> ":" <+> text (show e)
                          return m)
diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs
index 53c33ccbfe..7d8331198a 100644
--- a/ghc/GHCi/UI/Tags.hs
+++ b/ghc/GHCi/UI/Tags.hs
@@ -24,6 +24,8 @@ import GHC.Types.Name (nameOccName)
 import GHC.Types.Name.Occurrence (pprOccName)
 import GHC.Core.ConLike
 import GHC.Utils.Monad
+import GHC.Unit.State
+import GHC.Driver.Env
 
 import Control.Monad
 import Data.Function
@@ -93,12 +95,13 @@ listModuleTags m = do
     Nothing -> return []
     Just mInfo -> do
        dflags <- getDynFlags
+       unit_state <- hsc_units <$> getSession
        mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
        let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
        let names = fromMaybe [] $ GHC.modInfoTopLevelScope mInfo
        let localNames = filter ((m==) . nameModule) names
        mbTyThings <- mapM GHC.lookupName localNames
-       return $! [ tagInfo dflags unqual exported kind name realLoc
+       return $! [ tagInfo dflags unit_state unqual exported kind name realLoc
                      | tyThing <- catMaybes mbTyThings
                      , let name = getName tyThing
                      , let exported = GHC.modInfoIsExportedName mInfo name
@@ -127,12 +130,13 @@ data TagInfo = TagInfo
 
 
 -- get tag info, for later translation into Vim or Emacs style
-tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
+tagInfo :: DynFlags -> UnitState -> PrintUnqualified
+        -> Bool -> Char -> Name -> RealSrcLoc
         -> TagInfo
-tagInfo dflags unqual exported kind name loc
+tagInfo dflags unit_state unqual exported kind name loc
     = TagInfo exported kind
-        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
-        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
+        (showSDocForUser dflags unit_state unqual $ pprOccName (nameOccName name))
+        (showSDocForUser dflags unit_state unqual $ ftext (srcLocFile loc))
         (srcLocLine loc) (srcLocCol loc) Nothing
 
 -- throw an exception when someone tries to overwrite existing source file (fix for #10989)