Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC Commits: 32ebd77d by fendor at 2026-05-28T16:58:16+02:00 Never modify UnitInfo for better sharing - - - - - 4 changed files: - compiler/GHC/Driver/Main/Interactive.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs Changes: ===================================== 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/Unit/State.hs ===================================== @@ -27,6 +27,9 @@ module GHC.Unit.State ( lookupUnitId, lookupUnitId', unsafeLookupUnitId, + isUnitTrusted, + isUnitIdTrusted, + isUnitInfoTrusted, lookupPackageName, resolvePackageImport, @@ -433,6 +436,9 @@ data UnitState = UnitState { -- may have the 'exposed' flag be 'False'.) unitInfoMap :: UnitInfoMap, + trustedUnits :: Set.Set UnitId, + distrustedUnits :: Set.Set UnitId, + -- | The set of transitively reachable units according -- to the explicitly provided command line arguments. -- A fully instantiated VirtUnit may only be replaced by a RealUnit from @@ -492,6 +498,8 @@ data UnitState = UnitState { emptyUnitState :: UnitState emptyUnitState = UnitState { unitInfoMap = emptyUniqMap, + trustedUnits = Set.empty, + distrustedUnits = Set.empty, preloadClosure = emptyUniqSet, packageNameMap = emptyUFM, wireMap = emptyUniqMap, @@ -624,6 +632,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 @@ -852,11 +875,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 = @@ -892,22 +910,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 @@ -1547,9 +1571,16 @@ mkUnitState logger cfg = do 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 @@ -1572,11 +1603,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 -- @@ -1724,6 +1756,8 @@ mkUnitState logger cfg = do , explicitUnits = explicit_pkgs , homeUnitDepends = home_unit_deps , unitInfoMap = pkg_db + , trustedUnits = trusted + , distrustedUnits = distrusted , preloadClosure = emptyUniqSet , moduleNameProvidersMap = mod_map , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map @@ -2170,10 +2204,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. ===================================== ghc/GHCi/UI.hs ===================================== @@ -2919,11 +2919,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 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32ebd77d3fcddbcf3c81acec1b4233e3... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32ebd77d3fcddbcf3c81acec1b4233e3... You're receiving this email because of your account on gitlab.haskell.org.