[Git][ghc/ghc][wip/fendor/external-unit-db-cache] 9 commits: Fixup: Expose TrustOverlay API and add docs

21 Jul 2026

Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC


Commits:
5aa49c01 by fendor at 2026-07-21T13:59:21+02:00
Fixup: Expose TrustOverlay API and add docs

- - - - -
2bc401c5 by fendor at 2026-07-21T14:07:26+02:00
Fixup: get rid of commented out fields

- - - - -
34290c1b by fendor at 2026-07-21T14:08:34+02:00
Fixup: get rid of unproven bang for homeUnitDepends

- - - - -
07901d15 by fendor at 2026-07-21T14:14:18+02:00
Fixup: remove debug remnant

- - - - -
0b32af7b by fendor at 2026-07-21T14:21:15+02:00
Fixup: Strictness of TrustOverlay field

- - - - -
2f7b984e by fendor at 2026-07-21T14:38:08+02:00
fixup! Add test for multiple home units to show that the number of UnitInfo's doesn't increase

- - - - -
3120f9cf by fendor at 2026-07-21T15:42:29+02:00
Fixup: better docs and notes for UnitIndex vs UnitState

- - - - -
7bc96202 by fendor at 2026-07-21T16:04:14+02:00
Fixup: Move ExternalDatatbaseCache into UnitIndex

- - - - -
02a77b79 by fendor at 2026-07-21T16:04:48+02:00
Fixup: one better comment

- - - - -


11 changed files:

- compiler/GHC.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/External/Database.hs
- compiler/GHC/Unit/External/Index.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
- testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs


Changes:

=====================================
compiler/GHC.hs
=====================================
@@ -671,7 +671,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do
   logger <- getLogger
   hsc_env <- getSession
 
-  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env)
+  (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hscUIC hsc_env) (hsc_all_home_unit_ids hsc_env)
   updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
 
   let upd hue =
@@ -760,7 +760,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
               old_hpt = homeUnitEnv_hpt homeUnitEnv
               home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
 
-          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) (ue_eud old_unit_env) home_units
+          (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic old_unit_env) home_units
 
           updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
           pure HomeUnitEnv
@@ -778,7 +778,6 @@ setProgramDynFlags_ invalidate_needed dflags = do
               , ue_current_unit    = ue_currentUnit old_unit_env
               , ue_module_graph    = ue_module_graph old_unit_env
               , ue_eps             = ue_eps old_unit_env
-              , ue_eud             = ue_eud old_unit_env
               , ue_uic      = ue_uic old_unit_env
               }
         modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
@@ -837,7 +836,6 @@ setProgramHUG_ invalidate_needed new_hug0 = do
             , ue_current_unit    = ue_currentUnit unit_env0
             , ue_eps             = ue_eps unit_env0
             , ue_module_graph    = ue_module_graph unit_env0
-            , ue_eud             = ue_eud unit_env0
             , ue_uic      = ue_uic unit_env0
             }
       modifySession $ \h ->
@@ -886,7 +884,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
           old_hpt = homeUnitEnv_hpt homeUnitEnv
           home_units = HUG.allUnits (ue_home_unit_graph unit_env)
 
-      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) (ue_eud unit_env) home_units
+      (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_uic unit_env) home_units
 
       updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
       pure HomeUnitEnv


=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Types.Error (mkUnknownDiagnostic)
 import qualified GHC.Unit.Home.Graph as HUG
 import GHC.Unit.Home.ModInfo
 import GHC.Unit.Home.PackageTable
-import GHC.Unit.External.Database (cacheExternalUnitDatabase)
+import GHC.Unit.External.Index (cacheExternalUnitDatabase)
 
 -- | Entry point to compile a Backpack file.
 doBackpack :: [FilePath] -> Ghc ()
@@ -442,8 +442,8 @@ addInMemoryDatabase dflags u = do
           { unitDatabasePath  = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags (ppr (unitId u)) ++ ")"
           , unitDatabaseUnits = [u]
           }
-    let eud = hscEUDC hsc_env
-    liftIO $ cacheExternalUnitDatabase eud newdb
+    let uic = hscUIC hsc_env
+    liftIO $ cacheExternalUnitDatabase uic newdb
     -- added at the end because ordering matters
     pure dflags
           { packageDBFlags = packageDBFlags dflags ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))]
@@ -456,11 +456,10 @@ addUnit u = do
     logger <- getLogger
     let dflags0 = hsc_dflags hsc_env
     let old_unit_env = hsc_unit_env hsc_env
-    let eud = hscEUDC hsc_env
 
     dflags1 <- addInMemoryDatabase dflags0 u
 
-    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) eud (hsc_all_home_unit_ids hsc_env)
+    (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_uic old_unit_env) (hsc_all_home_unit_ids hsc_env)
 
 
     -- update platform constants
@@ -477,7 +476,6 @@ addUnit u = do
                     (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit))
           , ue_eps       = ue_eps old_unit_env
           , ue_module_graph = ue_module_graph old_unit_env
-          , ue_eud       = ue_eud old_unit_env
           , ue_uic = ue_uic old_unit_env
           }
     setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }


=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -14,7 +14,6 @@ module GHC.Driver.Env
    , hsc_HUG
    , hsc_all_home_unit_ids
    , hscUnitIndex
-   , hscUIC
    , hscUpdateLoggerFlags
    , hscUpdateHUG
    , hscInsertHPT
@@ -27,7 +26,7 @@ module GHC.Driver.Env
    , runInteractiveHsc
    , hscEPS
    , hscEUD
-   , hscEUDC
+   , hscUIC
    , hscInterp
    , prepareAnnotations
    , discardIC
@@ -228,10 +227,7 @@ hscEPS :: HscEnv -> IO ExternalPackageState
 hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))
 
 hscEUD :: HscEnv -> IO (ExternalUnitDatabases UnitId)
-hscEUD = readExternalUnitDatabases . hscEUDC
-
-hscEUDC :: HscEnv -> ExternalUnitDatabaseCache UnitId
-hscEUDC hsc_env = ue_eud (hsc_unit_env hsc_env)
+hscEUD = readExternalUnitDatabases . hscUIC
 
 hscUnitIndex :: HscEnv -> IO UnitIndex
 hscUnitIndex hsc_env = ueUI (hsc_unit_env hsc_env)


=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -131,7 +131,7 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
   home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
     let hue_flags = homeUnitEnv_dflags homeUnitEnv
         dflags = homeUnitEnv_dflags homeUnitEnv
-    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) (hscEUDC hsc_env) home_units
+    (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units
 
     updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
     emptyHpt <- liftIO $ emptyHomePackageTable


=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -178,19 +178,21 @@ data UnitEnv = UnitEnv
     , ue_namever   :: !GhcNameVersion
         -- ^ GHC name/version (used for dynamic library suffix)
 
-    , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId)
-        -- ^ Global cache of already read package databases
-
     , ue_uic :: {-# UNPACK #-} !UnitIndexCache
-        -- ^ Index of already processed 'UnitInfo's.
-        -- Shares state over all 'UnitState' in the 'HomeUnitGraph'.
+        -- ^ Global index of already processed external units.
+        -- Shares state over all 'UnitState's in the 'HomeUnitGraph'.
+        --
+        -- Allows sharing of 'UnitInfo's, ensuring each individual 'UnitInfo'
+        -- is retained a constant number of times.
+        --
+        -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
     }
 
 ueEPS :: UnitEnv -> IO ExternalPackageState
 ueEPS = eucEPS . ue_eps
 
 ueEUD :: UnitEnv -> IO (ExternalUnitDatabases UnitId)
-ueEUD = readExternalUnitDatabases . ue_eud
+ueEUD = readExternalUnitDatabases . ue_uic
 
 ueUI :: UnitEnv -> IO UnitIndex
 ueUI = readUnitIndex . ue_uic
@@ -199,7 +201,6 @@ ueUI = readUnitIndex . ue_uic
 initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
 initUnitEnv cur_unit hug namever platform = do
   eps <- initExternalUnitCache
-  eud <- initExternalUnitDatabaseCache
   uic <- initUnitIndexCache
   return $ UnitEnv
     { ue_eps             = eps
@@ -208,7 +209,6 @@ initUnitEnv cur_unit hug namever platform = do
     , ue_current_unit    = cur_unit
     , ue_platform        = platform
     , ue_namever         = namever
-    , ue_eud             = eud
     , ue_uic      = uic
     }
 


=====================================
compiler/GHC/Unit/External/Database.hs
=====================================
@@ -1,18 +1,11 @@
 module GHC.Unit.External.Database (
-  -- * Mutable cache for 'ExternalUnitDatabases'
-  ExternalUnitDatabaseCache (..),
-  initExternalUnitDatabaseCache,
-  readExternalUnitDatabases,
-  readExternalUnitDatabase,
-  cacheExternalUnitDatabase,
-  clearExternalUnitDatabaseCache,
   -- * 'ExternalUnitDatabases'
   ExternalUnitDatabases,
   emptyExternalUnitDatabases,
   insertExternalUnitDatabases,
   deleteExternalUnitDatabases,
   lookupExternalUnitDatabases,
-  -- * 'UnitDatabase'
+  -- * 'UnitDatabase' and how to merge them.
   UnitDatabase (..),
   mergeDatabases,
   UnitPrecedenceMap,
@@ -20,8 +13,6 @@ module GHC.Unit.External.Database (
   compareByPreference,
   -- * Reading packages from disk.
   UnitDbConfig (..),
-  readOrGetUnitDatabase,
-  readUnitDatabases,
   readUnitDatabase,
   getUnitDbRefs,
   resolveUnitDatabase,
@@ -48,8 +39,6 @@ import GHC.Utils.Panic
 
 import Control.Monad
 import Data.Char
-import Data.IORef
-import Data.IORef qualified as IORef
 import Data.List (sortBy)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -60,40 +49,6 @@ import System.Directory
 import System.Environment (getEnv)
 import System.FilePath as FilePath

--- ----------------------------------------------------------------------------
--- ExternalUnitDatabaseCache
--- ----------------------------------------------------------------------------
-
--- | Mutable wrapper around 'ExternalUnitDatabases'.
-newtype ExternalUnitDatabaseCache unit = ExternalUnitDatabaseCache
-  { eudc_databases :: IORef (ExternalUnitDatabases unit)
-  }
-
-initExternalUnitDatabaseCache :: IO (ExternalUnitDatabaseCache unit)
-initExternalUnitDatabaseCache =
-  ExternalUnitDatabaseCache <$> IORef.newIORef emptyExternalUnitDatabases
-
-readExternalUnitDatabases :: ExternalUnitDatabaseCache unit -> IO (ExternalUnitDatabases unit)
-readExternalUnitDatabases eudc =
-  IORef.readIORef (eudc_databases eudc)
-
-modifyExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> (ExternalUnitDatabases unit -> ExternalUnitDatabases unit) -> IO ()
-modifyExternalUnitDatabaseCache eudc f =
-  IORef.modifyIORef' (eudc_databases eudc) f
-
-readExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> OsPath -> IO (Maybe (UnitDatabase unit))
-readExternalUnitDatabase eudc path = do
-  dbs <- readExternalUnitDatabases eudc
-  pure $ lookupExternalUnitDatabases path dbs
-
-cacheExternalUnitDatabase :: ExternalUnitDatabaseCache unit -> UnitDatabase unit -> IO ()
-cacheExternalUnitDatabase eudc db =
-  modifyExternalUnitDatabaseCache eudc (insertExternalUnitDatabases db)
-
-clearExternalUnitDatabaseCache :: ExternalUnitDatabaseCache unit -> IO ()
-clearExternalUnitDatabaseCache eudc =
-  modifyExternalUnitDatabaseCache eudc (const emptyExternalUnitDatabases)
-
 -- ----------------------------------------------------------------------------
 -- ExternalUnitDatabases
 -- ----------------------------------------------------------------------------
@@ -230,12 +185,6 @@ data UnitDbConfig = UnitDbConfig
   , unitDbConfigGHCDir :: FilePath
   }
 
-readUnitDatabases :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> IO [UnitDatabase UnitId]
-readUnitDatabases logger db_cache cfg = do
-  conf_refs <- getUnitDbRefs cfg
-  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
-  mapM (readOrGetUnitDatabase logger db_cache cfg) confs
-
 getUnitDbRefs :: UnitDbConfig -> IO [PkgDbRef]
 getUnitDbRefs cfg = do
   let system_conf_refs = [UserPkgDb, GlobalPkgDb]
@@ -285,17 +234,6 @@ resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
   if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
 resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
 
--- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
-readOrGetUnitDatabase :: Logger -> ExternalUnitDatabaseCache UnitId -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
-readOrGetUnitDatabase logger db_cache cfg conf_file =
-  readExternalUnitDatabase db_cache conf_file >>= \ case
-    Nothing -> do
-      new_db <- readUnitDatabase logger cfg conf_file
-      cacheExternalUnitDatabase db_cache new_db
-      pure new_db
-    Just db ->
-      pure db
-
 -- | Read the 'UnitDatabase' at the given location.
 readUnitDatabase :: Logger -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
 readUnitDatabase logger cfg conf_file = do


=====================================
compiler/GHC/Unit/External/Index.hs
=====================================
@@ -6,12 +6,16 @@ module GHC.Unit.External.Index (
   readUnitIndex,
   modifyUnitIndexCache,
   clearUnitIndexCache,
+  cacheExternalUnitDatabase,
+  readExternalUnitDatabases,
+  readExternalUnitDatabase,
   -- * 'UnitIndex'
   UnitIndex,
   emptyUnitIndex,
   wiringMap,
   unwiringMap,
   globalUnits,
+  externalUnitDatabases,
   setWireMap,
   wireMapExists,
   addUnitInfoMap,
@@ -32,10 +36,14 @@ module GHC.Unit.External.Index (
   updateWiredInUnits,
   updateWiredInUnitsInUnitInfo,
   updateWiredInUnitIdInModule,
+  -- * Reading external unit databases into the 'UnitIndexCache'
+  readOrGetUnitDatabase,
+  readUnitDatabases,
 ) where
 
 import GHC.Prelude
 
+import GHC.Data.OsPath
 import GHC.Data.ShortText qualified as ST
 import GHC.Types.Unique.Map
 import GHC.Unit.Database
@@ -46,17 +54,36 @@ import GHC.Unit.Info
 import GHC.Unit.Types
 import GHC.Utils.Logger
 
+import Control.Monad (liftM)
 import Data.Either
 import Data.IORef (IORef)
 import Data.IORef qualified as IORef
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
+import Data.Maybe (catMaybes)
 
 -- ----------------------------------------------------------------------------
 -- UnitIndex
 -- ----------------------------------------------------------------------------
 
 -- | Mutable version of 'UnitIndex'.
+--
+-- The 'UnitIndexCache' ensures that all calls to 'initUnits' will
+-- share the 'UnitInfo' if it is possible.
+--
+-- To share the 'UnitInfo', it needs to be fully-resolved, i.e., its wired-in
+-- dependencies and modules need to be resolved.
+-- Thus, the 'UnitIndexCache' caches both the global 'WireMap' and the 'UnitInfoMap'.
+--
+-- The 'WireMap' is globally valid, as other parts of the compiler rely on the fact
+-- that only one instance of wired-in units is used.
+--
+-- Memory Invariant: The 'UnitIndexCache' is the root object for retaining fully-resolved
+-- 'UnitInfo'. 'UnitState' is expected to reference only 'UnitInfo's from the 'UnitIndexCache'.
+-- There is exactly one fully-resolved 'UnitInfo' alive for each external unit per unit database.
+--
+-- A second instance may or may not be stored in the 'externalUnitDatabases', which represent the
+-- in-memory cache of the on-disk unit databases.
 newtype UnitIndexCache = UnitIndexCache
   { uic_index :: IORef UnitIndex
   }
@@ -66,21 +93,41 @@ initUnitIndexCache =
   UnitIndexCache <$> IORef.newIORef emptyUnitIndex
 
 readUnitIndex :: UnitIndexCache -> IO UnitIndex
-readUnitIndex eudc =
-  IORef.readIORef (uic_index eudc)
+readUnitIndex uic =
+  IORef.readIORef (uic_index uic)
 
 modifyUnitIndexCache :: UnitIndexCache -> (UnitIndex -> UnitIndex) -> IO ()
-modifyUnitIndexCache eudc f =
-  IORef.modifyIORef' (uic_index eudc) f
+modifyUnitIndexCache uic f =
+  IORef.modifyIORef' (uic_index uic) f
 
 clearUnitIndexCache :: UnitIndexCache -> IO ()
-clearUnitIndexCache eudc =
-  modifyUnitIndexCache eudc (const emptyUnitIndex)
+clearUnitIndexCache uic =
+  modifyUnitIndexCache uic (const emptyUnitIndex)
+
+cacheExternalUnitDatabase :: UnitIndexCache -> UnitDatabase UnitId -> IO ()
+cacheExternalUnitDatabase uic db =
+  modifyUnitIndexCache uic
+    (\ ui ->
+      ui
+        { ui_externalUnitDatabases = insertExternalUnitDatabases db (ui_externalUnitDatabases ui)
+        }
+    )
+
+readExternalUnitDatabases :: UnitIndexCache -> IO (ExternalUnitDatabases UnitId)
+readExternalUnitDatabases uic =
+  externalUnitDatabases <$> readUnitIndex uic
+
+readExternalUnitDatabase :: UnitIndexCache -> OsPath -> IO (Maybe (UnitDatabase UnitId))
+readExternalUnitDatabase uic path = do
+  dbs <- readExternalUnitDatabases uic
+  pure $ lookupExternalUnitDatabases path dbs
 
 -- | Global index for external units that can be shared across multiple 'HomeUnitEnv's.
 --
 -- Allows sharing of the 'WireMap' and 'UnitInfo's that are stored in the 'UnitState'
 -- of each 'HomeUnitEnv'.
+--
+-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details about memory usage.
 data UnitIndex = UnitIndex
   { ui_wireMap :: !WireMap
     -- ^ A mapping from database unit keys to wired in unit ids.
@@ -95,10 +142,13 @@ data UnitIndex = UnitIndex
   , ui_unitInfoMap :: !GlobalUnitInfoMap
     -- ^ A global map for all fully-resolved 'UnitInfo's.
     --
-    -- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
-    -- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
-    -- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
-    -- variables such as @${pkgroot}@ in paths.
+    -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more details
+    -- what we use this for and what a fully-resolved 'UnitInfo' is.
+  , ui_externalUnitDatabases :: !(ExternalUnitDatabases UnitId)
+    -- ^ Cache the already processed unit databases in-memory.
+    --
+    -- These 'GenericUnitInfo's have their paths resolved, e.g., no @${pkgroot}@ is
+    -- present any more.
   }
 
 -- | Get the 'WireMap'.
@@ -115,7 +165,18 @@ wiringMap = ui_wireMap
 unwiringMap :: UnitIndex -> UnwireMap
 unwiringMap = ui_unwireMap
 
+-- | Access the already processed unit databases.
+externalUnitDatabases :: UnitIndex -> ExternalUnitDatabases UnitId
+externalUnitDatabases = ui_externalUnitDatabases
+
 -- | Access the global map of fully-resolved 'UnitInfo's.
+--
+-- A 'UnitInfo' is fully-resolved, if its dependencies were updated to reference the
+-- wired-in packages (e.g., 'wiringMap') and the wired-in packages are updated.
+-- Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
+-- variables such as @${pkgroot}@ in paths.
+--
+-- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for why this is helpful.
 globalUnits :: UnitIndex -> GlobalUnitInfoMap
 globalUnits = ui_unitInfoMap
 
@@ -124,6 +185,7 @@ emptyUnitIndex = UnitIndex
   { ui_wireMap = emptyWireMap
   , ui_unwireMap = emptyUnwireMap
   , ui_unitInfoMap = emptyGlobalUnitInfoMap
+  , ui_externalUnitDatabases = emptyExternalUnitDatabases
   }
 
 -- | Set the 'WireMap' of 'UnitIndex'.
@@ -167,7 +229,8 @@ type UnitAbiHash = ST.ShortText
 --
 -- However, a user can choose a conflicting 'UnitId', causing a conflict after all.
 -- We use the 'UnitAbiHash' for disambiguation. If both 'UnitId' and 'UnitAbiHash' are
--- identical in separate unit databases, we can assume they are the same unit.
+-- identical in separate unit databases, we can assume they are the same unit, according
+-- to the documentation of GHC.
 newtype GlobalUnitInfoMap = GlobalUnitInfoMap (UniqMap UnitId (Map UnitAbiHash UnitInfo))
 
 -- | Lookup the 'UnitInfo' in the 'GlobalUnitInfoMap'.
@@ -310,3 +373,23 @@ upd_wired_in :: WireMap -> UnitId -> UnitId
 upd_wired_in wiredInMap key
     | Just key' <- lookupWireMap key wiredInMap = key'
     | otherwise = key
+
+-- -----------------------------------------------------------------------------
+-- Reading the unit database(s) into the 'UnitIndexCache'
+
+readUnitDatabases :: Logger -> UnitIndexCache -> UnitDbConfig -> IO [UnitDatabase UnitId]
+readUnitDatabases logger db_cache cfg = do
+  conf_refs <- getUnitDbRefs cfg
+  confs     <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
+  mapM (readOrGetUnitDatabase logger db_cache cfg) confs
+
+-- | Get the cached 'UnitDatabase' or read the 'UnitDatabase' at the given location.
+readOrGetUnitDatabase :: Logger -> UnitIndexCache -> UnitDbConfig -> OsPath -> IO (UnitDatabase UnitId)
+readOrGetUnitDatabase logger db_cache cfg conf_file =
+  readExternalUnitDatabase db_cache conf_file >>= \ case
+    Nothing -> do
+      new_db <- readUnitDatabase logger cfg conf_file
+      cacheExternalUnitDatabase db_cache new_db
+      pure new_db
+    Just db ->
+      pure db


=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -6,7 +6,6 @@ module GHC.Unit.State (
         module GHC.Unit.Info,
         -- * Reading the package config, and processing cmdline args
         UnitState(..),
-        TrustOverlay(..),
         UnitDatabase (..),
         UnitErr (..),
         emptyUnitState,
@@ -16,6 +15,13 @@ module GHC.Unit.State (
         getUnitDbRefs,
         resolveUnitDatabase,
         listUnitInfo,
+        -- * Overlays over the unit set
+        TrustOverlay,
+        IsTrusted(..),
+        lookupTrustOverlay,
+        distrustUnits,
+        trustUnits,
+        emptyTrustOverlay,
         -- * Querying the package config
         lookupUnit,
         lookupUnit',
@@ -252,12 +258,19 @@ data IsTrusted
   | Distrusted
   deriving ( Eq, Ord )
 
+-- | The 'TrustOverlay' stores user overwrites of the on-disk 'unitIsTrusted' status.
+--
+-- The user can overwrite this value via flags such as @-distrust-all-packages@.
+-- We do not modify the 'UnitInfo' directory, but rather store this user selection
+-- in the 'TrustOverlay'.
+--
+-- This allows us to share the 'UnitInfo' completely and saves us memory.
 newtype TrustOverlay = TrustOverlay
   { trustOverlay :: UniqMap UnitId IsTrusted
   }
 
 lookupTrustOverlay :: TrustOverlay -> UnitId -> Maybe IsTrusted
-lookupTrustOverlay (TrustOverlay to) = lookupUniqMap to
+lookupTrustOverlay to = lookupUniqMap (trustOverlay to)
 
 distrustUnits :: [UnitId] -> TrustOverlay -> TrustOverlay
 distrustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addToUniqMap acc uid Distrusted) to elements
@@ -268,6 +281,52 @@ trustUnits elements (TrustOverlay to) = TrustOverlay $ foldl' (\ acc uid -> addT
 emptyTrustOverlay :: TrustOverlay
 emptyTrustOverlay = TrustOverlay emptyUniqMap
 
+{-
+Note [Sharing 'UnitInfo's across the 'UnitEnv']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'UnitState' and 'UnitIndex' are closely related.
+
+The 'UnitState' stores all information about the external units referenced by
+a single HomeUnitEnv.
+This includes in particular the 'unitInfoMap', an in-memory representation of
+the unit databases that a 'HomeUnitEnv' depends on.
+Multiple home units can depend on the same unit database, leading to a linear
+increase of 'UnitInfo's per 'HomeUnitEnv'. (It used to be quadratic even, due
+to accidentally retaining old 'UnitInfo's.)
+Thus, we want to share the 'UnitInfo' across multiple 'HomeUnitEnv's.
+This where the 'UnitIndex' is needed.
+
+The 'UnitIndex' stores all fully-resolved 'UnitInfo's that can be referenced
+by the 'UnitState'.'unitInfoMap'.
+We consider a 'UnitInfo' as fully-resolved, if its dependencies were updated to reference the
+wired-in units (e.g., 'wiringMap') and the wired-in units are updated as well.
+See Note [Wired-in units] for more details on wired-in units.
+Further, the 'UnitInfo' is based on the 'ExternalUnitDatabases' results, resolving
+variables such as @${pkgroot}@ in paths.
+
+As such, we can consider the 'UnitIndex' to be global data that is referenced by
+the 'UnitState' for better sharing of 'UnitInfo's.
+
+In fact, using the 'UnitIndex', we can impose a hard upper bound on the number
+of live 'UnitInfo's in a GHC session:
+
+> For each on-disk 'GenericUnitInfo', there are at most two objects alive.
+
+One instance is stored in 'ExternalUnitDatabases' where variables are resolved,
+but the wired-in units haven't been resolved.
+
+The second instance is the fully-resolved 'UnitInfo' stored in the 'UnitIndex'.
+-}
+
+-- | The 'UnitState' contains a plethora of information local to a single 'HomeUnitEnv'.
+--
+-- It stores module visibilities, unit trust for @SafeHaskell@, available units for error messages,
+-- explicit unit dependencies and knows how to instantiate backpack signature and holes
+-- on demand.
+--
+-- A 'HomeUnitEnv' should rarely/never have to look into the 'UnitIndex', all external
+-- unit related information is stored in the 'UnitState'.
+--
 data UnitState = UnitState {
   -- | A mapping of 'Unit' to 'UnitInfo'.  This list is adjusted
   -- so that only valid units are here.  'UnitInfo' reflects
@@ -276,6 +335,7 @@ data UnitState = UnitState {
   -- may have the 'exposed' flag be 'False'.)
   --
   -- All values are shared with 'UnitIndex'.'globalUnits'.
+  -- See Note [Sharing 'UnitInfo's across the 'UnitEnv'] for details.
   unitInfoMap :: UnitInfoMap,
 
   -- | Set of units that we trust.
@@ -283,7 +343,10 @@ data UnitState = UnitState {
   -- Local overlay of 'UnitInfo'.
   -- This avoids modifying the 'UnitInfo' directly, potentially saving
   -- a lot of duplication.
-  trustedUnits :: TrustOverlay,
+  --
+  -- We keep this in WHNF as it is relatively cheap but could easily retain
+  -- references to bigger structures.
+  trustedUnits :: !TrustOverlay,
 
   -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same
   -- package name (e.g. different instantiations), then we return one of them...
@@ -333,8 +396,6 @@ emptyUnitState = UnitState {
     unitInfoMap    = emptyUniqMap,
     trustedUnits   = emptyTrustOverlay,
     packageNameMap = emptyUFM,
-    -- wireMap        = emptyUniqMap,
-    -- unwireMap      = emptyUniqMap,
     preloadUnits   = [],
     explicitUnits  = [],
     homeUnitDepends = Set.empty,
@@ -439,14 +500,16 @@ isUnitInfoTrusted ue u =
 -- 'initUnits' can be called again subsequently after updating the
 -- 'packageFlags' and 'packageDBFlags' fields of the 'DynFlags', and it will
 -- update the 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> UnitIndexCache -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags unit_index cached_dbs home_units = do
+--
+-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for implementation details.
+initUnits :: Logger -> DynFlags -> UnitIndexCache -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags unit_index home_units = do
 
   let forceUnitInfoMap state = unitInfoMap state `seq` ()
 
   unit_state <- withTiming logger (text "initializing unit database")
                    forceUnitInfoMap
-                 $ mkUnitState logger unit_index cached_dbs (initUnitConfig dflags  home_units)
+                 $ mkUnitState logger unit_index (initUnitConfig dflags  home_units)
 
   putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
     FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -638,10 +701,9 @@ reportCycles logger sccs = when (logVerbAtLeast logger 2) $ mapM_ report sccs
 mkUnitState
     :: Logger
     -> UnitIndexCache
-    -> ExternalUnitDatabaseCache UnitId
     -> UnitConfig
     -> IO UnitState
-mkUnitState logger unit_index db_cache cfg = do
+mkUnitState logger unit_index cfg = do
 {-
    Plan.
 
@@ -695,7 +757,7 @@ mkUnitState logger unit_index db_cache cfg = do
           we build a mapping saying what every in scope module name points to.
 -}
 
-  dbs <- readUnitDatabases logger db_cache (initUnitDbConfig cfg)
+  dbs <- readUnitDatabases logger unit_index (initUnitDbConfig cfg)
 
   -- distrust all units if the flag is set
   let distrustUnitsOfDb overlay db = foldl' (\ acc ui -> distrustUnits [unitId ui] acc) overlay (unitDatabaseUnits db)
@@ -713,7 +775,7 @@ mkUnitState logger unit_index db_cache cfg = do
   debugTraceMsg logger 2 $
       text "package flags" <+> ppr other_flags
 
-  let !home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
+  let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
 
   -- Merge databases together, without checking validity
   (pkg_map1, prec_map) <- mergeDatabases logger dbs
@@ -727,7 +789,7 @@ mkUnitState logger unit_index db_cache cfg = do
 
   -- Compute trust flags (these flags apply regardless of whether
   -- or not packages are visible or not)
-  !trustUnitsOverlay <- mayThrowUnitErr
+  trustUnitsOverlay <- mayThrowUnitErr
             $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
                  distrustedUnitsOverlay (reverse (unitConfigFlagsTrusted cfg))
   let pkgs1 = nonDetEltsUniqMap pkg_map2
@@ -769,12 +831,12 @@ mkUnitState logger unit_index db_cache cfg = do
                             -- Note: we NEVER expose indefinite packages by
                             -- default, because it's almost assuredly not
                             -- what you want (no mix-in linking has occurred).
-                            let !x = fsPackageName p in if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
+                            if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p
                                then addToUniqMap vm (mkUnit p)
                                                UnitVisibility {
                                                  uv_expose_all = True,
                                                  uv_renamings = [],
-                                                 uv_package_name = First (Just x),
+                                                 uv_package_name = First (Just $ fsPackageName p),
                                                  uv_requirements = emptyUniqMap,
                                                  uv_explicit = Nothing
                                                }


=====================================
ghc/GHCi/UI.hs
=====================================
@@ -857,7 +857,7 @@ installInteractiveHomeUnits dflags = do
       env <- GHC.getSession
       let unit_index = hscUIC env
       (unit_state,home_unit,_mconstants) <-
-        liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units
+        liftIO $ initUnits logger dflags unit_index all_home_units
       hpt <- liftIO emptyHomePackageTable
       pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit))
 


=====================================
testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout
=====================================
@@ -0,0 +1,2 @@
+### Heap Census
+There are exactly two GenericUnitInfo closures alive per on-disk package 


=====================================
testsuite/tests/driver/TUnitInfo/generic-unit-info-space.hs
=====================================
@@ -87,7 +87,7 @@ initGhcM numOfPkgs xs = do
       -- If this number changes without a good reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak.
       -- We say less than the expected size is accepted, because in the multiple-home-units case, we don't force the second
       -- UnitInfo closure enough after initial processing.
-      when (num <= expectedSizeInBytes) $ do
+      when (num > expectedSizeInBytes) $ do
         putStrLn "Space leak detected by generic-unit-info-space test:"
         putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when <= (" ++ show expectedNumberOfUnitInfos ++ ") are expected"
         readFile hpFile >>= putStrLn



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4247f659925671ed5a4259e1ea5846...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d4247f659925671ed5a4259e1ea5846...
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

    

Hannes Siebenhandl (＠fendor)

tags

participants (1)