Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 85ec1752 by fendor at 2026-07-22T13:18:01+02:00 Add test for multiple home units to show that the number of UnitInfo's doesn't increase - - - - - 16 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/External/ModuleOrigin.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - testsuite/tests/driver/TUnitInfo/Makefile - testsuite/tests/driver/TUnitInfo/all.T - + testsuite/tests/driver/TUnitInfo/genMhu.sh - + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-mhu.stdout - + testsuite/tests/driver/TUnitInfo/generic-unit-info-space-single.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 ===================================== @@ -1,3 +1,45 @@ +-- | The 'UnitIndex' is a 'UnitEnv' wide data structure that shares +-- external unit information across the 'UnitState' of all home units +-- (e.g., 'HomeUnitEnv') in a particular 'UnitEnv'. +-- +-- It caches already read unit databases, all processed 'UnitInfo's and +-- the 'WireMap'. +-- +-- This module is meant to be imported as @Index@. +-- +-- A short overview of how the different types here related to 'UnitState', 'UnitEnv' +-- and the 'HomeUnitEnv'. +-- +-- ┌─────────┐ +-- │ UnitEnv │ +-- └────┬────┘ +-- ├───────────────────────┐ +-- │ │ +-- ┌────▼──────┐ ┌─────▼─────┐ +-- │HomeUnitEnv│ │ UnitIndex ├────────────────┐ +-- └────┬──────┘ └───────────┘ │ +-- │ │ +-- │ Reads cached unit DBs │ +-- ┌────▼──────┐ ┌─────────────────────┐ │ +-- │ UnitState ├──────────>ExternalUnitDatabases◄──────┤ +-- └────┬──┬───┘ └─────────────────────┘ │ +-- │ └───────────────────────┐ │ +-- │ Writes new UnitInfos │ │ +-- │ during initialisation │ │ +-- ┌────▼────────┐ ┌────────v──────────┐ │ +-- │ UnitInfoMap │ │ GlobalUnitInfoMap ◄────────┘ +-- └────┬────────┘ └────────^──────────┘ +-- │ │ +-- └──────────────────────────┘ +-- UnitInfoMap references +-- GlobalUnitInfoMap values +-- (All UnitInfos are shared) +-- +-- Open arrow @A ───> B@: A uses B. +-- Closed arrow @A ◄─── B@: A is a field of B. +-- +-- Also, see Note [Sharing 'UnitInfo's across the 'UnitEnv'] for more technical discussion +-- about sharing 'UnitInfo's. module GHC.Unit.External.Index ( -- * The 'UnitIndexCache'. -- A mutable wrapper around 'UnitIndex' @@ -6,12 +48,16 @@ module GHC.Unit.External.Index ( readUnitIndex, modifyUnitIndexCache, clearUnitIndexCache, + cacheExternalUnitDatabase, + readExternalUnitDatabases, + readExternalUnitDatabase, -- * 'UnitIndex' UnitIndex, emptyUnitIndex, wiringMap, unwiringMap, globalUnits, + externalUnitDatabases, setWireMap, wireMapExists, addUnitInfoMap, @@ -32,10 +78,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 +96,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', the 'UnitInfo' needs to be fully-resolved, i.e., its wired-in +-- dependencies and modules need to be replaced with the 'UnitId' of the wired-in unit. +-- 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 +135,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 +184,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 +207,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 +227,7 @@ emptyUnitIndex = UnitIndex { ui_wireMap = emptyWireMap , ui_unwireMap = emptyUnwireMap , ui_unitInfoMap = emptyGlobalUnitInfoMap + , ui_externalUnitDatabases = emptyExternalUnitDatabases } -- | Set the 'WireMap' of 'UnitIndex'. @@ -167,7 +271,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'. @@ -238,7 +343,10 @@ updateWiredInUnitIndex wired_map pkgs unit_index = do ui <- readUnitIndex unit_index let all_pkgs = updateWiredInUnits wired_map (ui_unitInfoMap ui) pkgs - (new_pkgs, _pkgs_set) = partitionEithers all_pkgs + (new_pkgs', _pkgs_set) = partitionEithers all_pkgs + -- Make sure we force the 'UnitInfo' here. + -- Otherwise, we will retain a reference to the old 'UnitInfo' + new_pkgs <- traverse evaluateUnitInfoLists new_pkgs' modifyUnitIndexCache unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) pure (map (either id id) all_pkgs) @@ -310,3 +418,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/External/ModuleOrigin.hs ===================================== @@ -7,12 +7,12 @@ module GHC.Unit.External.ModuleOrigin ( originEmpty, ) where +import Data.Semigroup qualified as Semigroup import GHC.Prelude import GHC.Unit.External.Validate import GHC.Unit.Info import GHC.Utils.Outputable import GHC.Utils.Panic -import qualified Data.Semigroup as Semigroup -- | Given a module name, there may be multiple ways it came into scope, -- possibly simultaneously. This data type tracks all the possible ways ===================================== 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,57 @@ 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'. +As a reminder, the 'HomeUnitEnv' stores all information specific to a single home unit, +such as the 'HomePackageTable', 'DynFlags' and the 'UnitState'. +The 'UnitState' retains 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, and reference the same +'UnitInfo's across the GHC session. +We share all 'UnitInfo's across multiple 'HomeUnitEnv's, saving a lot of +duplication of the same 'UnitInfo'. +This what the 'UnitIndex' takes care of. + +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'. + +See the module documentation for 'GHC.Unit.External.Index' for an overview +of how the types relate to each other. +-} + +-- | 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 +340,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 +348,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 +401,6 @@ emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, trustedUnits = emptyTrustOverlay, packageNameMap = emptyUFM, - -- wireMap = emptyUniqMap, - -- unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], homeUnitDepends = Set.empty, @@ -439,14 +505,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 +706,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 +762,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 +780,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 +794,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 +836,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/Makefile ===================================== @@ -2,17 +2,38 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -.PHONY: generic-unit-info-space_Prep -generic-unit-info-space_Prep: +.PHONY: generic-unit-info-space-single_Prep +generic-unit-info-space-single_Prep: -.PHONY: generic-unit-info-space -generic-unit-info-space: +.PHONY: generic-unit-info-space-single +generic-unit-info-space-single: "$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \ -package ghc -package base -package ghc-internal -threaded ./generic-unit-info-space$(exeext) \ "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \ "`'$(GHC_PKG)' --no-user-package-db list --simple-output | wc -w`" \ + -clear-package-db -global-package-db -no-user-package-db \ + +RTS -hT --no-automatic-heap-samples -RTS + +# Generate 50 trivial home units. The number of 'UnitInfo's must not increase +# linearly in the number of home units +HOME_UNITS_01 := 50 +UNITS := $(foreach p,$(shell seq 0 $$(( $(HOME_UNITS_01) - 1 ))),-unit @unitp$(p)) +.PHONY: generic-unit-info-space-mhu_Prep +generic-unit-info-space-mhu_Prep: + ./genMhu.sh $(HOME_UNITS_01) + + +.PHONY: generic-unit-info-space-mhu +generic-unit-info-space-mhu: + "$(TEST_HC)" $(TEST_HC_OPTS) -Wall -v0 generic-unit-info-space.hs -rtsopts \ + -package ghc -package base -package ghc-internal -threaded + + ./generic-unit-info-space$(exeext) \ + "`'$(TEST_HC)' --print-libdir | tr -d '\r'`" \ + "`'$(GHC_PKG)' --global list --simple-output | wc -w`" \ + $(UNITS) \ +RTS -hT --no-automatic-heap-samples -RTS ===================================== testsuite/tests/driver/TUnitInfo/all.T ===================================== @@ -1,7 +1,15 @@ # A test for checking the number of live GenericUnitInfo objects -test('generic-unit-info-space' - , [ extra_files(['Foo.hs']) - , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space_Prep') +test('generic-unit-info-space-single' + , [ extra_files(['Foo.hs', 'generic-unit-info-space.hs']) + , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-single_Prep') ] , makefile_test - , ['generic-unit-info-space']) + , ['generic-unit-info-space-single']) + +# A test for checking the number of live GenericUnitInfo objects +test('generic-unit-info-space-mhu' + , [ extra_files(['genMhu.sh', 'generic-unit-info-space.hs']) + , pre_cmd('$MAKE -s --no-print-directory generic-unit-info-space-mhu_Prep') + ] + , makefile_test + , ['generic-unit-info-space-mhu']) ===================================== testsuite/tests/driver/TUnitInfo/genMhu.sh ===================================== @@ -0,0 +1,26 @@ +#! /usr/bin/env bash + +set -euo pipefail + +HOME_UNITS=${1:-50} + +unit_dir() { echo "p$1"; } +unit_fname(){ echo "unitp$1"; } +mod_name() { echo "Mod$1"; } + +mk_unit_file() { + local p=$1 + echo "-clear-package-db -global-package-db -no-user-package-db -working-dir $(unit_dir "$p") -this-unit-id $(unit_dir "$p") $(mod_name "$p") ${deps[*]}" \ + > "$(unit_fname "$p")" +} + +mk_top_mod() { + local p=$1 + echo "module $(mod_name "$p") where" > "$(unit_dir "$p")/$(mod_name "$p").hs" +} + +for ((p = 0; p < HOME_UNITS; p++)); do + mkdir "$(unit_dir "$p")" + mk_unit_file "$p" + mk_top_mod "$p" +done ===================================== 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-single.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 ===================================== @@ -6,6 +6,7 @@ import GHC.Data.FastString (mkFastStringByteString) import qualified GHC.Data.ShortText as ST import GHC.Driver.Monad import GHC.Driver.Env.Types +import GHC.Driver.Session.Units import GHC.Internal.Heap.Closures (closureSize, asBox) import GHC.Platform import GHC.Profiling @@ -14,6 +15,7 @@ import GHC.Unit.Types (stringToUnitId) import Control.Monad (guard, when) import Data.Version (makeVersion) +import qualified Data.List.NonEmpty as NE import qualified Data.Maybe as Maybe import qualified Data.List as List import System.Environment @@ -24,19 +26,32 @@ main :: IO () main = do libdir:numberOfGlobalPkgsStr:restArgs <- getArgs runGhc (Just libdir) $ do - initGhcM (read numberOfGlobalPkgsStr) $ ["-clear-package-db", "-global-package-db", "-no-user-package-db"] ++ restArgs - + initGhcM (read numberOfGlobalPkgsStr) restArgs initGhcM :: Int -> [String] -> Ghc () initGhcM numOfPkgs xs = do session <- getSession df1 <- getSessionDynFlags - let cmdOpts = ["-fforce-recomp"] ++ xs + let (units, args) = extractUnits xs + let cmdOpts = ["-fforce-recomp"] ++ args + (df2, leftovers, _) <- parseDynamicFlags (hsc_logger session) df1 (map noLoc cmdOpts) setSessionDynFlags df2 - ts <- mapM (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers - setTargets ts - _ <- load LoadAllTargets + + targets <- case NE.nonEmpty units of + Nothing -> + traverse (\s -> guessTarget s Nothing Nothing) $ map unLoc leftovers + Just mhu -> do + ts <- initMulti mhu (\ _ _ _ _ -> pure ()) + traverse (\(n, mu, mp) -> guessTarget n mu mp) ts + + setTargets targets + success <- load LoadAllTargets + + liftIO $ when (failed success) $ do + putStrLn "Failed to load targets" + Exit.exitFailure + liftIO $ do requestHeapCensus performGC @@ -64,15 +79,17 @@ initGhcM numOfPkgs xs = do -- The output should be: -- -- @ - -- 2 * number of packages in global unit db * 8 * word_size * sizeof(struct GenericUnitInfo) + -- 2 * number of packages in global unit db * word_size * sizeof(struct GenericUnitInfo) -- @ -- - -- This test simply assures, that in a single home unit case, we don't leak 'UnitInfo's + -- This test simply assures, that when we load a session, we don't leak 'UnitInfo's -- - -- If this number changes for any reason, DO NOT ACCEPT THE CHANGES, you have introduced a space leak. - when (num /= expectedSizeInBytes) $ 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 putStrLn "Space leak detected by generic-unit-info-space test:" - putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when == (" ++ show expectedNumberOfUnitInfos ++ ") are expected" + putStrLn $ (show (num `div` genericUnitInfoSizeInBytes)) ++ " live GenericUnitInfo when <= (" ++ show expectedNumberOfUnitInfos ++ ") are expected" readFile hpFile >>= putStrLn Exit.exitFailure return () @@ -135,3 +152,11 @@ minimalUnitInfo = GenericUnitInfo , unitIsExposed = True , unitIsTrusted = False } + +extractUnits :: [String] -> ([String], [String]) +extractUnits = go [] [] + where + -- TODO: we should likely use the 'processCmdLineP' instead + go units rest ("-unit" : x : xs) = go (x : units) rest xs + go units rest (x : xs) = go units (x : rest) xs + go units rest [] = (reverse units, reverse rest) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85ec1752a307b199cfecc40e63fe2e0b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/85ec1752a307b199cfecc40e63fe2e0b... 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