Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: e5ff4198 by fendor at 2026-06-16T15:01:30+02:00 WIP: introduce external unit database cache - - - - - 78f7f4a4 by fendor at 2026-06-16T15:02:50+02:00 Never modify UnitInfo for better sharing - - - - - fd08e959 by fendor at 2026-06-16T15:03:08+02:00 WIP: Introduce UnitIndex for global data - - - - - 15 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/Unit/Env.hs - + compiler/GHC/Unit/External/Database.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - libraries/ghc-boot/GHC/Unit/Database.hs - utils/haddock/haddock-api/src/Haddock.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -671,15 +671,12 @@ setUnitDynFlagsNoCheck uid dflags1 = do logger <- getLogger hsc_env <- getSession - let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env) - let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env) + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (hsc_unit_index hsc_env) (hscEUDC hsc_env) (hsc_all_home_unit_ids hsc_env) updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let upd hue = hue { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_home_unit = Just home_unit } @@ -759,17 +756,15 @@ setProgramDynFlags_ invalidate_needed dflags = do old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv + let dflags = homeUnitEnv_dflags homeUnitEnv old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index old_unit_env) (ue_eud old_unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants pure HomeUnitEnv { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt , homeUnitEnv_home_unit = Just home_unit @@ -783,6 +778,8 @@ 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_unit_index = ue_unit_index old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } else modifySession (hscSetFlags dflags0) @@ -840,6 +837,8 @@ 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_unit_index = ue_unit_index unit_env0 } modifySession $ \h -> -- hscSetFlags takes care of updating the logger as well. @@ -881,19 +880,17 @@ setProgramHUG_ invalidate_needed new_hug0 = do updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv) updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - dflags = case HUG.unitEnv_lookup_maybe uid updates of + let dflags = case HUG.unitEnv_lookup_maybe uid updates of Nothing -> homeUnitEnv_dflags homeUnitEnv Just env -> homeUnitEnv_dflags env old_hpt = homeUnitEnv_hpt homeUnitEnv home_units = HUG.allUnits (ue_home_unit_graph unit_env) - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_unit_index unit_env) (ue_eud unit_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants pure HomeUnitEnv { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt , homeUnitEnv_home_unit = Just home_unit ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -92,6 +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) -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () @@ -174,6 +175,8 @@ withBkpSession :: UnitId -> BkpM a withBkpSession cid insts deps session_type do_this = do dflags <- getDynFlags + env <- getSession + unitIndex <- liftIO $ hscUnitIndex env let cid_fs = unitFS cid is_primary = False uid_str = unpackFS (mkInstantiatedUnitHash cid insts) @@ -193,8 +196,8 @@ withBkpSession cid insts deps session_type do_this = do | otherwise = sub_comp (key_base p) mk_temp_env hsc_env = - hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env - mk_temp_dflags unit_state dflags = dflags + hscUpdateFlags (\dflags -> mk_temp_dflags unitIndex (hsc_units hsc_env) dflags) hsc_env + mk_temp_dflags unit_index unit_state dflags = dflags { backend = case session_type of TcSession -> noBackend _ -> backend dflags @@ -241,7 +244,7 @@ withBkpSession cid insts deps session_type do_this = do , importPaths = [] -- Synthesize the flags , packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> - let uid = unwireUnit unit_state + let uid = unwireUnit unit_index $ renameHoleUnit unit_state (listToUFM insts) uid0 in ExposePackage (showSDoc dflags @@ -348,9 +351,9 @@ buildUnit session cid insts lunit = do | otherwise = [Nothing] linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + unit_index <- liftIO $ hscUnitIndex hsc_env let obj_files = concatMap linkableFiles linkables - state = hsc_units hsc_env compat_fs = unitIdFS cid compat_pn = PackageName compat_fs @@ -376,7 +379,7 @@ buildUnit session cid insts lunit = do -- really used for anything, so we leave it -- blank for now. TcSession -> [] - _ -> map (toUnitId . unwireUnit state) + _ -> map (toUnitId . unwireUnit unit_index) $ deps ++ [ moduleUnit mod | (_, mod) <- insts , not (isHoleModule mod) ], @@ -435,18 +438,24 @@ addUnit u = do logger <- getLogger let dflags0 = hsc_dflags hsc_env let old_unit_env = hsc_unit_env hsc_env - newdbs <- case ue_unit_dbs old_unit_env of - Nothing -> panic "addUnit: called too early" - Just dbs -> - let newdb = UnitDatabase - { unitDatabasePath = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" - , unitDatabaseUnits = [u] - } - in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env) + + -- TODO @fendor: provide an API to programmatically add an in-memory DB + let newdb = UnitDatabase + { unitDatabasePath = unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" + , unitDatabaseUnits = [u] + } + let eud = hscEUDC hsc_env + liftIO $ cacheExternalUnitDatabase eud newdb + -- added at the end because ordering matters + let dflags1 = dflags0 + { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] + } + + (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 (ue_unit_index old_unit_env) eud (hsc_all_home_unit_ids hsc_env) + -- update platform constants - dflags <- liftIO $ updatePlatformConstants dflags0 mconstants + dflags <- liftIO $ updatePlatformConstants dflags1 mconstants let unit_env = UnitEnv { ue_platform = targetPlatform dflags @@ -456,9 +465,11 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) + (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_unit_index = ue_unit_index old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -13,6 +13,8 @@ module GHC.Driver.Env , hsc_HUE , hsc_HUG , hsc_all_home_unit_ids + , hscUnitIndex + , hsc_unit_index , hscUpdateLoggerFlags , hscUpdateHUG , hscInsertHPT @@ -24,6 +26,8 @@ module GHC.Driver.Env , mkInteractiveHscEnv , runInteractiveHsc , hscEPS + , hscEUD + , hscEUDC , hscInterp , prepareAnnotations , discardIC @@ -89,6 +93,7 @@ import GHC.Builtin.Names import Data.IORef import qualified Data.Set as Set +import GHC.Unit.External.Database (ExternalUnitDatabaseCache, readExternalUnitDatabases, ExternalUnitDatabases) runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env hsc = do @@ -221,6 +226,18 @@ configured via command-line flags (in `GHC.setTopSessionDynFlags`). 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) + +hscUnitIndex :: HscEnv -> IO UnitIndex +hscUnitIndex hsc_env = readIORef $ ue_unit_index (hsc_unit_env hsc_env) + +hsc_unit_index :: HscEnv -> IORef UnitIndex +hsc_unit_index hsc_env = ue_unit_index (hsc_unit_env hsc_env) + -------------------------------------------------------------------------------- -- * Queries on Transitive Closure -------------------------------------------------------------------------------- ===================================== compiler/GHC/Driver/Main/Hsc.hs ===================================== @@ -110,7 +110,7 @@ newHscEnv top_dir dflags = do where home_unit_graph hpt = HUG.unitEnv_singleton (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) + (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing) newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do ===================================== compiler/GHC/Driver/Main/Interactive.hs ===================================== @@ -275,7 +275,7 @@ hscCheckSafe' m l = do Sf_Safe | not trust_own_pkg -> True Sf_SafeInferred | not trust_own_pkg -> True _ | isHomeModule home_unit mod -> True - _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) + _ -> isUnitTrusted unit_state (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -297,7 +297,7 @@ checkPkgTrust pkgs = do errors = S.foldr go emptyBag pkgs state = hsc_units hsc_env go pkg acc - | unitIsTrusted $ unsafeLookupUnitId state pkg + | isUnitIdTrusted state pkg = acc | otherwise = (`consBag` acc) ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -1328,7 +1328,7 @@ hscCheckSafe' m l = do Sf_Safe | not trust_own_pkg -> True Sf_SafeInferred | not trust_own_pkg -> True _ | isHomeModule home_unit mod -> True - _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) + _ -> isUnitTrusted unit_state (moduleUnit m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -1350,7 +1350,7 @@ checkPkgTrust pkgs = do errors = S.foldr go emptyBag pkgs state = hsc_units hsc_env go pkg acc - | unitIsTrusted $ unsafeLookupUnitId state pkg + | isUnitIdTrusted state pkg = acc | otherwise = (`consBag` acc) ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -129,16 +129,14 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do let home_units = HUG.allUnits initial_home_graph home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv - hue_flags = homeUnitEnv_dflags homeUnitEnv + let hue_flags = homeUnitEnv_dflags homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hsc_unit_index hsc_env) (hscEUDC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants emptyHpt <- liftIO $ emptyHomePackageTable pure $ HomeUnitEnv { homeUnitEnv_units = unit_state - , homeUnitEnv_unit_dbs = Just dbs , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = emptyHpt , homeUnitEnv_home_unit = Just home_unit @@ -239,7 +237,7 @@ createUnitEnvFromFlags unitDflags = do unitEnvList <- forM unitDflags $ \dflags -> do emptyHpt <- emptyHomePackageTable let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing + HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing return (homeUnitId_ dflags, newInternalUnitEnv) let activeUnit = fst $ NE.head unitEnvList return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -80,7 +80,6 @@ module GHC.Unit.Env -- ** Queries on the current active home unit , ue_homeUnitState - , ue_unit_dbs , ue_homeUnit , ue_unitFlags @@ -110,6 +109,7 @@ import GHC.Prelude import qualified Data.Set as Set import GHC.Unit.External +import GHC.Unit.External.Database import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types @@ -131,6 +131,7 @@ import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import Data.IORef -------------------------------------------------------------------------------- -- The hard queries @@ -174,6 +175,11 @@ data UnitEnv = UnitEnv , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) + + , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) + -- TODO: @fendor Docs + , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) + -- TODO: @fendor Docs } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -182,6 +188,8 @@ ueEPS = eucEPS . ue_eps initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache + eud <- initExternalUnitDatabaseCache + unit_index <- newIORef (initUnitIndex) return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug @@ -189,6 +197,8 @@ initUnitEnv cur_unit hug namever platform = do , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever + , ue_eud = eud + , ue_unit_index = unit_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv @@ -258,9 +268,6 @@ ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) o ue_homeUnitState :: HasDebugCallStack => UnitEnv -> UnitState ue_homeUnitState = HUG.homeUnitEnv_units . ue_currentHomeUnitEnv -ue_unit_dbs :: UnitEnv -> Maybe [UnitDatabase UnitId] -ue_unit_dbs = HUG.homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv - -- ------------------------------------------------------- -- Query and modify Home Package Table in HomeUnitEnv -- ------------------------------------------------------- ===================================== compiler/GHC/Unit/External/Database.hs ===================================== @@ -0,0 +1,104 @@ +module GHC.Unit.External.Database ( + -- * + ExternalUnitDatabaseCache (..), + initExternalUnitDatabaseCache, + readExternalUnitDatabases, + readExternalUnitDatabase, + cacheExternalUnitDatabase, + clearExternalUnitDatabaseCache, + -- * + ExternalUnitDatabases, + emptyExternalUnitDatabases, + insertExternalUnitDatabases, + deleteExternalUnitDatabases, + lookupExternalUnitDatabases, + -- * + UnitDatabase (..), +) where + +import GHC.Prelude + +import GHC.Data.OsPath +import GHC.Unit.Info +import GHC.Utils.Outputable + +import Data.IORef (IORef) +import Data.IORef qualified as IORef +import Data.Map.Strict +import Data.Map.Strict qualified as Map + +-- ---------------------------------------------------------------------------- +-- ExternalUnitDatabaseCache +-- ---------------------------------------------------------------------------- + +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 +-- ---------------------------------------------------------------------------- + +data ExternalUnitDatabases unit = ExternalUnitDatabases + { eud_cachedDatabases :: !(Map OsPath (UnitDatabase unit)) + } + +emptyExternalUnitDatabases :: ExternalUnitDatabases unit +emptyExternalUnitDatabases = + ExternalUnitDatabases + { eud_cachedDatabases = Map.empty + } + +insertExternalUnitDatabases :: UnitDatabase unit -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit +insertExternalUnitDatabases unit_db eud = + ExternalUnitDatabases + { eud_cachedDatabases = Map.insert (unitDatabasePath unit_db) unit_db (eud_cachedDatabases eud) + } + +deleteExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> ExternalUnitDatabases unit +deleteExternalUnitDatabases unit_db_path eud = + ExternalUnitDatabases + { eud_cachedDatabases = Map.delete unit_db_path (eud_cachedDatabases eud) + } + +lookupExternalUnitDatabases :: OsPath -> ExternalUnitDatabases unit -> Maybe (UnitDatabase unit) +lookupExternalUnitDatabases key eud = + Map.lookup key (eud_cachedDatabases eud) + +-- ---------------------------------------------------------------------------- +-- UnitDatabase +-- ---------------------------------------------------------------------------- + +-- | Unit database +data UnitDatabase unit = UnitDatabase + { unitDatabasePath :: OsPath + , unitDatabaseUnits :: [GenUnitInfo unit] + } + +instance (Outputable u) => Outputable (UnitDatabase u) where + ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -128,16 +128,6 @@ data HomeUnitEnv = HomeUnitEnv { homeUnitEnv_units :: !UnitState -- ^ External units - , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId]) - -- ^ Stack of unit databases for the target platform. - -- - -- This field is populated with the result of `initUnits`. - -- - -- 'Nothing' means the databases have never been read from disk. - -- - -- Usually we don't reload the databases from disk if they are - -- cached, even if the database flags changed! - , homeUnitEnv_dflags :: DynFlags -- ^ The dynamic flag settings , homeUnitEnv_hpt :: HomePackageTable @@ -164,10 +154,9 @@ data HomeUnitEnv = HomeUnitEnv -- ^ Home-unit } -mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv -mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv +mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us - , homeUnitEnv_unit_dbs = dbs , homeUnitEnv_dflags = dflags , homeUnitEnv_hpt = hpt , homeUnitEnv_home_unit = home_unit ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -5,12 +5,20 @@ module GHC.Unit.State ( module GHC.Unit.Info, + UnitIndex(..), + initUnitIndex, + setWireMap, + isWireMapEmpty, + addUnitInfoMap, + -- lookupUnitInfoMap, + -- * Reading the package config, and processing cmdline args UnitState(..), UnitDatabase (..), UnitErr (..), emptyUnitState, initUnits, + readOrGetUnitDatabase, readUnitDatabases, readUnitDatabase, getUnitDbRefs, @@ -25,6 +33,9 @@ module GHC.Unit.State ( lookupUnitId, lookupUnitId', unsafeLookupUnitId, + isUnitTrusted, + isUnitIdTrusted, + isUnitInfoTrusted, lookupPackageName, resolvePackageImport, @@ -118,6 +129,9 @@ import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set import Control.Applicative +import GHC.Unit.External.Database +import Data.IORef +import Data.Either (partitionEithers) -- --------------------------------------------------------------------------- -- The Unit state @@ -342,7 +356,7 @@ data UnitConfig = UnitConfig , unitConfigHideAll :: !Bool -- ^ Hide all units by default , unitConfigHideAllPlugins :: !Bool -- ^ Hide all plugins units by default - , unitConfigDBCache :: Maybe [UnitDatabase UnitId] + , unitConfigDBCache :: !(ExternalUnitDatabaseCache UnitId) -- ^ Cache of databases to use, in the order they were specified on the -- command line (later databases shadow earlier ones). -- If Nothing, databases will be found using `unitConfigFlagsDB`. @@ -356,7 +370,7 @@ data UnitConfig = UnitConfig , unitConfigHomeUnits :: Set.Set UnitId } -initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig +initUnitConfig :: DynFlags -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> UnitConfig initUnitConfig dflags cached_dbs home_units = let !hu_id = homeUnitId_ dflags !hu_instanceof = homeUnitInstanceOf_ dflags @@ -419,25 +433,73 @@ initUnitConfig dflags cached_dbs home_units = type ModuleNameProvidersMap = UniqMap ModuleName (UniqMap Module ModuleOrigin) +data GlobalUnitKey = + GlobalUnitKey + UnitId -- ^ Unit Id of the 'UnitInfo' + ST.ShortText + +data UnitIndex = UnitIndex + { ui_wireMap :: WiringMap + -- ^ TODO @fendor: document global property + , ui_unwireMap :: UnwiringMap + -- ^ TODO @fendor: document global property + , ui_unitInfoMap :: UnitInfoMap + -- ^ TODO @fendor: This needs to be Map (UnitId, AbiHash) UnitInfo for absolut correctness + } + +initUnitIndex :: UnitIndex +initUnitIndex = UnitIndex + { ui_wireMap = emptyUniqMap + , ui_unwireMap = emptyUniqMap + , ui_unitInfoMap = emptyUniqMap + } + +setWireMap :: WiringMap -> UnitIndex -> UnitIndex +setWireMap wired_map unit_index = + unit_index + { ui_wireMap = wired_map + , ui_unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + } + +isWireMapEmpty :: UnitIndex -> Bool +isWireMapEmpty unit_index = + isNullUniqMap (ui_wireMap unit_index) + +addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex +addUnitInfoMap unit_info_map unit_index = + unit_index + { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index + } + +-- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo +-- lookupUnitInfoMap unit_index unit_id = +-- lookupUniqMap (ui_unitInfoMap unit_index) unit_id + data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted -- so that only valid units are here. 'UnitInfo' reflects -- what was stored *on disk*, except for the 'trusted' flag, which -- is adjusted at runtime. (In particular, some units in this map -- may have the 'exposed' flag be 'False'.) + -- + -- TODO @fendor: All values are shared with 'UnitIndex.ui_unitInfoMap'. unitInfoMap :: UnitInfoMap, + -- | Local overlay for the unit info so that sharing is more accurate + trustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet + distrustedUnits :: Set.Set UnitId, -- TODO @fendor: UniqSet + -- | A mapping of 'PackageName' to 'UnitId'. If several units have the same -- package name (e.g. different instantiations), then we return one of them... -- This is used when users refer to packages in Backpack includes. -- And also to resolve package qualifiers with the PackageImports extension. packageNameMap :: UniqFM PackageName UnitId, - -- | A mapping from database unit keys to wired in unit ids. - wireMap :: UniqMap UnitId UnitId, + -- -- | A mapping from database unit keys to wired in unit ids. + -- wireMap :: WiringMap, - -- | A mapping from wired in unit ids to unit keys from the database. - unwireMap :: UniqMap UnitId UnitId, + -- -- | A mapping from wired in unit ids to unit keys from the database. + -- unwireMap :: UnwiringMap, -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit @@ -479,9 +541,11 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, + trustedUnits = Set.empty, + distrustedUnits = Set.empty, packageNameMap = emptyUFM, - wireMap = emptyUniqMap, - unwireMap = emptyUniqMap, + -- wireMap = emptyUniqMap, + -- unwireMap = emptyUniqMap, preloadUnits = [], explicitUnits = [], homeUnitDepends = Set.empty, @@ -491,15 +555,6 @@ emptyUnitState = UnitState { allowVirtualUnits = False } --- | Unit database -data UnitDatabase unit = UnitDatabase - { unitDatabasePath :: OsPath - , unitDatabaseUnits :: [GenUnitInfo unit] - } - -instance Outputable u => Outputable (UnitDatabase u) where - ppr (UnitDatabase fp _u) = text "DB:" <+> ppr fp - type UnitInfoMap = UniqMap UnitId UnitInfo -- | Find the unit we know about with the given unit, if any @@ -618,6 +673,21 @@ mkUnitInfoMap infos = foldl' add emptyUniqMap infos listUnitInfo :: UnitState -> [UnitInfo] listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) +isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool +isUnitTrusted ue u = + Set.member (toUnitId u) (trustedUnits ue) && (Set.notMember (toUnitId u) (distrustedUnits ue)) + || unitIsTrusted (unsafeLookupUnit ue u) + +isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool +isUnitIdTrusted ue u = + Set.member u (trustedUnits ue) && (Set.notMember u (distrustedUnits ue)) + || unitIsTrusted (unsafeLookupUnitId ue u) + +isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool +isUnitInfoTrusted ue unit_info = + Set.member (unitId unit_info) (trustedUnits ue) && (Set.notMember (unitId unit_info) (distrustedUnits ue)) + || unitIsTrusted unit_info + -- ---------------------------------------------------------------------------- -- Loading the unit db files and building up the unit state @@ -628,20 +698,22 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants) -initUnits logger dflags cached_dbs home_units = do +initUnits :: Logger -> DynFlags -> IORef UnitIndex -> ExternalUnitDatabaseCache UnitId -> Set.Set UnitId -> IO (UnitState, HomeUnit, Maybe PlatformConstants) +initUnits logger dflags unit_index cached_dbs home_units = do - let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () + let forceUnitInfoMap state = unitInfoMap state `seq` () - (unit_state,dbs) <- withTiming logger (text "initializing unit database") + unit_state <- withTiming logger (text "initializing unit database") forceUnitInfoMap - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units) + $ mkUnitState logger unit_index (initUnitConfig dflags cached_dbs home_units) putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) - let home_unit = mkHomeUnit unit_state + wireMap <- ui_wireMap <$> readIORef unit_index + + let home_unit = mkHomeUnit wireMap (homeUnitId_ dflags) (homeUnitInstanceOf_ dflags) (homeUnitInstantiations_ dflags) @@ -663,19 +735,18 @@ initUnits logger dflags cached_dbs home_units = do Nothing -> return Nothing Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info)) - return (dbs,unit_state,home_unit,mconstants) + return (unit_state,home_unit,mconstants) mkHomeUnit - :: UnitState + :: WiringMap -> UnitId -- ^ Home unit id -> Maybe UnitId -- ^ Home unit instance of -> [(ModuleName, Module)] -- ^ Home unit instantiations -> HomeUnit -mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ = +mkHomeUnit wmap hu_id hu_instanceof hu_instantiations_ = let -- Some wired units can be used to instantiate the home unit. We need to -- replace their unit keys with their wired unit ids. - wmap = wireMap unit_state hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_ in case (hu_instanceof, hu_instantiations) of (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing @@ -700,7 +771,7 @@ readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId] readUnitDatabases logger cfg = do conf_refs <- getUnitDbRefs cfg confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs - mapM (readUnitDatabase logger cfg) confs + mapM (readOrGetUnitDatabase logger cfg) confs getUnitDbRefs :: UnitConfig -> IO [PkgDbRef] @@ -752,6 +823,18 @@ 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 -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) +readOrGetUnitDatabase logger cfg conf_file = + readExternalUnitDatabase (unitConfigDBCache cfg) conf_file >>= \ case + Nothing -> do + new_db <- readUnitDatabase logger cfg conf_file + cacheExternalUnitDatabase (unitConfigDBCache cfg) new_db + pure new_db + Just db -> + pure db + +-- | Read the 'UnitDatabase' at the given location. readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId) readUnitDatabase logger cfg conf_file = do isdir <- OsPath.doesDirectoryExist conf_file @@ -782,7 +865,8 @@ readUnitDatabase logger cfg conf_file = do pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo) proto_pkg_configs -- - return $ UnitDatabase conf_file' pkg_configs1 + pkg_configs2 <- traverse evaluateUnitInfo pkg_configs1 + return $ pkg_configs2 `seqList` UnitDatabase conf_file' pkg_configs2 where readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo] readDirStyleUnitInfo conf_dir = do @@ -834,11 +918,6 @@ readUnitDatabase logger cfg conf_file = do else return (Just []) -- ghc-pkg will create it when it's updated else return Nothing -distrustAllUnits :: [UnitInfo] -> [UnitInfo] -distrustAllUnits pkgs = map distrust pkgs - where - distrust pkg = pkg{ unitIsTrusted = False } - mungeUnitInfo :: OsPath -> OsPath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = @@ -866,6 +945,29 @@ mungeBytecodeLibFields pkg = ds -> ds } +evaluateUnitInfo :: UnitInfo -> IO UnitInfo +evaluateUnitInfo ui = do + importDirs <- evaluate $ unitImportDirs ui + includeDirs <- evaluate $ unitIncludeDirs ui + libraryDirs <- evaluate $ unitLibraryDirs ui + libraryBytecodeDirs <- evaluate $ unitLibraryBytecodeDirs ui + extDepFrameworkDirs <- evaluate $ unitExtDepFrameworkDirs ui + haddockInterfaces <- evaluate $ unitHaddockInterfaces ui + haddockHTMLs <- evaluate $ unitHaddockHTMLs ui + libraryDynDirs <- evaluate $ unitLibraryDynDirs ui + libraryDirsStatic <- evaluate $ unitLibraryDirsStatic ui + evaluate ui + { unitImportDirs = importDirs + , unitIncludeDirs = includeDirs + , unitLibraryDirs = libraryDirs + , unitLibraryDynDirs = libraryDynDirs + , unitLibraryDirsStatic = libraryDirsStatic + , unitLibraryBytecodeDirs = libraryBytecodeDirs + , unitExtDepFrameworkDirs = extDepFrameworkDirs + , unitHaddockInterfaces = haddockInterfaces + , unitHaddockHTMLs = haddockHTMLs + } + -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. @@ -874,22 +976,28 @@ applyTrustFlag :: UnitPrecedenceMap -> UnusableUnits -> [UnitInfo] + -> (Set.Set UnitId, Set.Set UnitId) -> TrustFlag - -> MaybeErr UnitErr [UnitInfo] -applyTrustFlag prec_map unusable pkgs flag = + -> MaybeErr UnitErr (Set.Set UnitId, Set.Set UnitId) +applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag = case flag of -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of Left ps -> Failed (TrustFlagErr flag ps) - Right (ps,qs) -> Succeeded (map trust ps ++ qs) - where trust p = p {unitIsTrusted=True} + Right (ps,_) -> Succeeded (insertAll ps trusted, removeAll ps distrusted) DistrustPackage str -> case selectPackages prec_map (PackageArg str) pkgs unusable of Left ps -> Failed (TrustFlagErr flag ps) - Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs) + Right (ps,_) -> Succeeded (removeAll ps trusted, insertAll ps distrusted) + +insertAll :: [UnitInfo] -> Set UnitId -> Set UnitId +insertAll elements set = foldl' (\ acc -> flip Set.insert acc . unitId) set elements + +removeAll :: [UnitInfo] -> Set UnitId -> Set UnitId +removeAll elements set = foldl' (\ acc -> flip Set.delete acc . unitId) set elements applyPackageFlag :: UnitPrecedenceMap @@ -1093,6 +1201,7 @@ pprTrustFlag flag = case flag of -- See Note [Wired-in units] in GHC.Unit.Types type WiringMap = UniqMap UnitId UnitId +type UnwiringMap = UniqMap UnitId UnitId findWiredInUnits :: Logger @@ -1100,9 +1209,7 @@ findWiredInUnits -> [UnitInfo] -- database -> VisibilityMap -- info on what units are visible -- for wired in selection - -> IO ([UnitInfo], -- unit database updated for wired in - WiringMap) -- map from unit id to wired identity - + -> IO WiringMap -- map from unit id to wired identity findWiredInUnits logger prec_map pkgs vis_map = do -- Now we must find our wired-in units, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described @@ -1165,27 +1272,41 @@ findWiredInUnits logger prec_map pkgs vis_map = do , not (unitIsIndefinite realUnitInfo) ] - updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs - where upd_pkg pkg - | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) - = pkg { unitId = wiredInUnitId - , unitInstanceOf = wiredInUnitId - -- every non instantiated unit is an instance of - -- itself (required by Backpack...) - -- - -- See Note [About units] in GHC.Unit - } - | otherwise - = pkg - upd_deps pkg = pkg { - unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), - unitExposedModules - = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) - (unitExposedModules pkg) - } - - - return (updateWiredInDependencies pkgs, wiredInMap) + return wiredInMap + +updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits wiredInMap knownInfos pkgs = + map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs + +updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = + let + upd_pkg pkg + | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) + = pkg { unitId = wiredInUnitId + , unitInstanceOf = wiredInUnitId + -- every non instantiated unit is an instance of + -- itself (required by Backpack...) + -- + -- See Note [About units] in GHC.Unit + } + | otherwise + = pkg + upd_deps pkg = pkg { + unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg), + unitExposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (unitExposedModules pkg) + } + in + case lookupUniqMap knownInfos (unitId pkg) of + Just ui -> + Right ui + Nothing -> + let + updated_pkg = upd_deps $ upd_pkg pkg + in + Left updated_pkg -- Helper functions for rewiring Module and Unit. These -- rewrite Units of modules in wired-in packages to the form known to the @@ -1468,9 +1589,10 @@ validateDatabase cfg pkg_map1 = mkUnitState :: Logger + -> IORef UnitIndex -> UnitConfig - -> IO (UnitState,[UnitDatabase UnitId]) -mkUnitState logger cfg = do + -> IO UnitState +mkUnitState logger unit_index cfg = do {- Plan. @@ -1524,15 +1646,19 @@ mkUnitState logger cfg = do we build a mapping saying what every in scope module name points to. -} - -- if databases have not been provided, read the database flags - raw_dbs <- case unitConfigDBCache cfg of - Nothing -> readUnitDatabases logger cfg - Just dbs -> return dbs + raw_dbs <- readUnitDatabases logger cfg -- distrust all units if the flag is set - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) } - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs - | otherwise = raw_dbs + let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db) + allUnits = Set.unions $ map unitsOf raw_dbs + + distrustedUnits + | unitConfigDistrustAll cfg = allUnits + | otherwise = Set.empty + + trustedUnits = Set.empty + + dbs = raw_dbs -- This, and the other reverse's that you will see, are due to the fact that @@ -1555,11 +1681,12 @@ mkUnitState logger cfg = do reportCycles logger sccs reportUnusable logger unusable - -- Apply trust flags (these flags apply regardless of whether + -- Compute trust flags (these flags apply regardless of whether -- or not packages are visible or not) - pkgs1 <- mayThrowUnitErr - $ foldM (applyTrustFlag prec_map unusable) - (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + (!trusted, !distrusted) <- mayThrowUnitErr + $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2)) + (trustedUnits, distrustedUnits) (reverse (unitConfigFlagsTrusted cfg)) + let pkgs1 = nonDetEltsUniqMap pkg_map2 let prelim_pkg_db = mkUnitInfoMap pkgs1 -- @@ -1625,7 +1752,21 @@ mkUnitState logger cfg = do -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. -- - (pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2 + ui <- readIORef unit_index + (wired_map, pkgs2) <- do + wireMap <- if isWireMapEmpty ui + then do + wmap <- findWiredInUnits logger prec_map pkgs1 vis_map2 + modifyIORef' unit_index (setWireMap wmap) + pure wmap + else do + pure $ ui_wireMap ui + + let all_pkgs = updateWiredInUnits wireMap (ui_unitInfoMap ui) pkgs1 + (new_pkgs, _pkgs_set) = partitionEithers all_pkgs + modifyIORef' unit_index (addUnitInfoMap $ mkUnitInfoMap new_pkgs) + pure (wireMap, map (either id id) all_pkgs) + let pkg_db = mkUnitInfoMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. @@ -1707,15 +1848,17 @@ mkUnitState logger cfg = do , explicitUnits = explicit_pkgs , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db + , trustedUnits = trusted + , distrustedUnits = distrusted , moduleNameProvidersMap = mod_map , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db plugin_vis_map , packageNameMap = pkgname_map - , wireMap = wired_map - , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] + -- , wireMap = wired_map + -- , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } - return (state, raw_dbs) + return state selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool selectHptFlag home_units (ExposePackage _ (UnitIdArg uid) _) | toUnitId uid `Set.member` home_units = True @@ -1732,9 +1875,9 @@ selectHomeUnits home_units flags = foldl' go Set.empty flags -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database. -unwireUnit :: UnitState -> Unit -> Unit +unwireUnit :: UnitIndex -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid) + maybe uid (RealUnit . Definite) (lookupUniqMap (ui_unwireMap state) def_uid) unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- @@ -2151,10 +2294,10 @@ pprUnitsWith pprIPI pkgstate = -- The idea is to only print package id, and any information that might -- be different from the package databases (exposure, trust) pprUnitsSimple :: UnitState -> SDoc -pprUnitsSimple = pprUnitsWith pprIPI +pprUnitsSimple ue = pprUnitsWith pprIPI ue where pprIPI ipi = let i = unitIdFS (unitId ipi) e = if unitIsExposed ipi then text "E" else text " " - t = if unitIsTrusted ipi then text "T" else text " " + t = if isUnitInfoTrusted ue ipi then text "T" else text " " in e <> t <> text " " <> ftext i -- | Show the mapping of modules to where they come from. ===================================== compiler/ghc.cabal.in ===================================== @@ -966,6 +966,7 @@ Library GHC.Unit GHC.Unit.Env GHC.Unit.External + GHC.Unit.External.Database GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home ===================================== ghc/GHCi/UI.hs ===================================== @@ -856,10 +856,12 @@ installInteractiveHomeUnits dflags = do where setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do - (dbs,unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags Nothing all_home_units + env <- GHC.getSession + let unit_index = hsc_unit_index env + (unit_state,home_unit,_mconstants) <- + liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] concatPackageDbStacksUsingLongestCommonPrefix stacks = @@ -2919,11 +2921,11 @@ isSafeModule m = do packageTrusted hsc_env md | isHomeModule (hsc_home_unit hsc_env) md = True - | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md) + | otherwise = isUnitTrusted (hsc_units hsc_env) (moduleUnit md) tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty) | otherwise = S.partition part deps - where part pkg = unitIsTrusted $ unsafeLookupUnitId unit_state pkg + where part pkg = isUnitIdTrusted unit_state pkg unit_state = hsc_units hsc_env dflags = hsc_dflags hsc_env ===================================== libraries/ghc-boot/GHC/Unit/Database.hs ===================================== @@ -746,11 +746,20 @@ mungeUnitInfoPaths top_dir pkgroot pkg = , unitHaddockHTMLs = munge_paths (munge_urls (unitHaddockHTMLs pkg)) } where - munge_paths = map munge_path - munge_urls = map munge_url + munge_paths = strictMap munge_path + munge_urls = strictMap munge_url (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf = OsPath.Internal.so + +strictMap :: (a -> b) -> [a] -> [b] +strictMap _ [] = [] +strictMap f (x:xs) = + let + !x' = f x + !xs' = strictMap f xs + in + x' : xs' ===================================== utils/haddock/haddock-api/src/Haddock.hs ===================================== @@ -258,7 +258,9 @@ haddockWithGhc ghc args = handleTopExceptions $ do logger' <- getLogger let logger = setLogFlags logger' (initLogFlags dflags) let parserOpts = Parser.initParserOpts dflags - !unit_state <- hsc_units <$> getSession + env <- getSession + let !unit_state = hsc_units env + !unit_index <- liftIO $ hscUnitIndex env -- If any --show-interface was used, show the given interfaces forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do @@ -285,7 +287,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do } -- Render the interfaces. - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages ifaces + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages ifaces -- If we were not given any input files, error if documentation was -- requested @@ -298,7 +300,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). - liftIO $ renderStep dflags parserOpts logger unit_state flags sinceQual qual concSem packages [] + liftIO $ renderStep dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem packages [] -- | Run the GHC action using a temporary output directory withTempOutputDir :: Ghc a -> Ghc a @@ -354,6 +356,7 @@ renderStep :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -362,7 +365,7 @@ renderStep -> [(DocPaths, Visibility, FilePath, InterfaceFile)] -> [Interface] -> IO () -renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem pkgs interfaces = do +renderStep dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem pkgs interfaces = do updateHTMLXRefs (map (\(docPath, _ifaceFilePath, _showModules, ifaceFile) -> ( case baseUrl flags of Nothing -> docPathsHtml docPath @@ -378,7 +381,7 @@ renderStep dflags parserOpts logger unit_state flags sinceQual nameQual concSem (DocPaths {docPathsSources=Just path}, _, _, ifile) <- pkgs iface <- ifInstalledIfaces ifile return (instMod iface, path) - render dflags parserOpts logger unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap + render dflags parserOpts logger unit_index unit_state flags sinceQual nameQual concSem interfaces installedIfaces extSrcMap where -- get package name from unit-id packageName :: Unit -> String @@ -392,6 +395,7 @@ render :: DynFlags -> ParserOpts -> Logger + -> UnitIndex -> UnitState -> [Flag] -> SinceQual @@ -401,7 +405,7 @@ render -> [(FilePath, PackageInterfaces)] -> Map Module FilePath -> IO () -render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do +render dflags parserOpts logger unit_index unit_state flags sinceQual qual concSem ifaces packages extSrcMap = do let packageInfo = PackageInfo { piPackageName = fromMaybe (PackageName mempty) $ optPackageName flags @@ -503,7 +507,7 @@ render dflags parserOpts logger unit_state flags sinceQual qual concSem ifaces p -- records the *wired in* identity base. So untranslate it -- so that we can service the request. unwire :: Module -> Module - unwire m = m { moduleUnit = unwireUnit unit_state (moduleUnit m) } + unwire m = m { moduleUnit = unwireUnit unit_index (moduleUnit m) } reexportedIfaces <- concat `fmap` (for (reexportFlags flags) $ \mod_str -> do let warn' = hPutStrLn stderr . ("Warning: " ++) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d499fe14e89d9e860eed142bc8db87d... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d499fe14e89d9e860eed142bc8db87d... You're receiving this email because of your account on gitlab.haskell.org.