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

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