[Git][ghc/ghc][wip/fendor/external-unit-db-cache] Never modify UnitInfo for better sharing

28 May 2026


      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.

    

Hannes Siebenhandl (＠fendor)

tags

participants (1)