Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 7f764864 by fendor at 2026-06-16T17:03:36+02:00 WIP: Introduce UnitIndex for global data - - - - - 9 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/State.hs - ghc/GHCi/UI.hs - libraries/ghc-boot/GHC/Unit/Database.hs - utils/haddock/haddock-api/src/Haddock.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 (hscEUDC hsc_env) (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 = @@ -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_eud old_unit_env) 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 @@ -779,6 +779,7 @@ setProgramDynFlags_ invalidate_needed dflags = do , 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) @@ -837,6 +838,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do , 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. @@ -884,7 +886,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_eud unit_env) 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 ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -175,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) @@ -194,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 @@ -242,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 @@ -349,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 @@ -377,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) ], @@ -449,7 +451,7 @@ addUnit u = do { packageDBFlags = packageDBFlags dflags0 ++ [PackageDB (PkgDbPath (unitDatabasePath newdb))] } - (unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 eud (hsc_all_home_unit_ids hsc_env) + (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 @@ -467,6 +469,7 @@ addUnit u = do , 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 @@ -230,6 +232,12 @@ 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/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 (hscEUDC hsc_env) 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 ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -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 @@ -177,6 +178,8 @@ data UnitEnv = UnitEnv , ue_eud :: {-# UNPACK #-} !(ExternalUnitDatabaseCache UnitId) -- TODO: @fendor Docs + , ue_unit_index :: {-# UNPACK #-} !(IORef UnitIndex) + -- TODO: @fendor Docs } ueEPS :: UnitEnv -> IO ExternalPackageState @@ -186,6 +189,7 @@ initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitE 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 @@ -194,6 +198,7 @@ initUnitEnv cur_unit hug namever platform = do , ue_platform = platform , ue_namever = namever , ue_eud = eud + , ue_unit_index = unit_index } updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -435,16 +435,25 @@ type ModuleNameProvidersMap = data GlobalUnitKey = GlobalUnitKey - UnitId -- ^ Unit Id of the 'UnitInfo' - ST.ShortText + !UnitId -- ^ Unit Id of the 'UnitInfo' + !ST.ShortText + +instance Uniquable GlobalUnitKey where + getUnique :: GlobalUnitKey -> Unique + getUnique (GlobalUnitKey unitId abiHash) = getUnique unitId -- TODO @fendor: how to incorporate abiHash + +globalUnitKeyFromUnitInfo :: UnitInfo -> GlobalUnitKey +globalUnitKeyFromUnitInfo u = GlobalUnitKey (unitId u) (unitAbiHash u) + +type GlobalUnitInfoMap = UniqMap GlobalUnitKey UnitInfo data UnitIndex = UnitIndex - { ui_wireMap :: WiringMap + { ui_wireMap :: !WiringMap -- ^ TODO @fendor: document global property - , ui_unwireMap :: UnwiringMap + , ui_unwireMap :: !UnwiringMap -- ^ TODO @fendor: document global property - , ui_unitInfoMap :: UnitInfoMap - -- ^ TODO @fendor: This needs to be Map (UnitId, AbiHash) UnitInfo for absolut correctness + , ui_unitInfoMap :: !GlobalUnitInfoMap + -- ^ TODO @fendor: This needs to be UniqMap GlobalUnitKey UnitInfo for absolut correctness } initUnitIndex :: UnitIndex @@ -468,8 +477,10 @@ isWireMapEmpty unit_index = addUnitInfoMap :: UnitInfoMap -> UnitIndex -> UnitIndex addUnitInfoMap unit_info_map unit_index = unit_index - { ui_unitInfoMap = unit_info_map `plusUniqMap` ui_unitInfoMap unit_index + { ui_unitInfoMap = globalMap `plusUniqMap` ui_unitInfoMap unit_index } + where + globalMap = listToUniqMap . map (\(_, v) -> (globalUnitKeyFromUnitInfo v, v)) $ nonDetUniqMapToList unit_info_map -- lookupUnitInfoMap :: UnitIndex -> UnitId -> Maybe UnitInfo -- lookupUnitInfoMap unit_index unit_id = @@ -945,28 +956,23 @@ mungeBytecodeLibFields pkg = ds -> ds } +seqUnitInfo :: UnitInfo -> b -> b +seqUnitInfo ui b = + unitImportDirs ui `seqList` + unitIncludeDirs ui `seqList` + unitLibraryDirs ui `seqList` + unitLibraryBytecodeDirs ui `seqList` + unitExtDepFrameworkDirs ui `seq` + unitHaddockInterfaces ui `seq` + unitHaddockHTMLs ui `seqList` + unitLibraryDynDirs ui `seqList` + unitLibraryDirsStatic ui `seqList` + unitDepends ui `seqList` + unitExposedModules ui `seqList` + b + 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 - } +evaluateUnitInfo ui = evaluate (seqUnitInfo ui ui) -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, @@ -1274,11 +1280,11 @@ findWiredInUnits logger prec_map pkgs vis_map = do return wiredInMap -updateWiredInUnits :: WiringMap -> UnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] +updateWiredInUnits :: WiringMap -> GlobalUnitInfoMap -> [UnitInfo] -> [Either UnitInfo UnitInfo] updateWiredInUnits wiredInMap knownInfos pkgs = map (updateWiredInUnitsInUnitInfo wiredInMap knownInfos) pkgs -updateWiredInUnitsInUnitInfo :: WiringMap -> UnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo +updateWiredInUnitsInUnitInfo :: WiringMap -> GlobalUnitInfoMap -> UnitInfo -> Either UnitInfo UnitInfo updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = let upd_pkg pkg @@ -1299,14 +1305,14 @@ updateWiredInUnitsInUnitInfo wiredInMap knownInfos pkg = (unitExposedModules pkg) } in - case lookupUniqMap knownInfos (unitId pkg) of + case lookupUniqMap knownInfos (globalUnitKeyFromUnitInfo pkg) of Just ui -> Right ui Nothing -> let updated_pkg = upd_deps $ upd_pkg pkg in - Left updated_pkg + Left $ seqUnitInfo updated_pkg updated_pkg -- Helper functions for rewiring Module and Unit. These -- rewrite Units of modules in wired-in packages to the form known to the @@ -1725,12 +1731,12 @@ mkUnitState logger unit_index 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). - if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p + let !x = fsPackageName p in 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 (fsPackageName p)), + uv_package_name = First (Just x), uv_requirements = emptyUniqMap, uv_explicit = Nothing } ===================================== ghc/GHCi/UI.hs ===================================== @@ -857,8 +857,9 @@ installInteractiveHomeUnits dflags = do setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv setupHomeUnitFor logger dflags all_home_units = do env <- GHC.getSession + let unit_index = hsc_unit_index env (unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (hscEUDC env) all_home_units + liftIO $ initUnits logger dflags unit_index (hscEUDC env) all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) ===================================== 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/-/commit/7f7648642ce4f72585aa4c8bc2c08622... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f7648642ce4f72585aa4c8bc2c08622... You're receiving this email because of your account on gitlab.haskell.org.