Hannes Siebenhandl pushed to branch wip/fendor/external-unit-db-cache at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/Driver/Main/Interactive.hs
    ... ... @@ -275,7 +275,7 @@ hscCheckSafe' m l = do
    275 275 
                 Sf_Safe | not trust_own_pkg         -> True
    276 276 
                 Sf_SafeInferred | not trust_own_pkg -> True
    277 277 
                 _ | isHomeModule home_unit mod      -> True
    278 
    -            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
    278 
    +            _ -> isUnitTrusted unit_state (moduleUnit m)
    279 279
    280 280 
         lookup' :: Module -> Hsc (Maybe ModIface)
    281 281 
         lookup' m = do
    ... ... @@ -297,7 +297,7 @@ checkPkgTrust pkgs = do
    297 297 
             errors = S.foldr go emptyBag pkgs
    298 298 
             state  = hsc_units hsc_env
    299 299 
             go pkg acc
    300 
    -            | unitIsTrusted $ unsafeLookupUnitId state pkg
    300 
    +            | isUnitIdTrusted state pkg
    301 301 
                 = acc
    302 302 
                 | otherwise
    303 303 
                 = (`consBag` acc)

  • compiler/GHC/Driver/Main/Passes.hs
    ... ... @@ -1328,7 +1328,7 @@ hscCheckSafe' m l = do
    1328 1328 
                 Sf_Safe | not trust_own_pkg         -> True
    1329 1329 
                 Sf_SafeInferred | not trust_own_pkg -> True
    1330 1330 
                 _ | isHomeModule home_unit mod      -> True
    1331 
    -            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
    1331 
    +            _ -> isUnitTrusted unit_state (moduleUnit m)
    1332 1332
    1333 1333 
         lookup' :: Module -> Hsc (Maybe ModIface)
    1334 1334 
         lookup' m = do
    ... ... @@ -1350,7 +1350,7 @@ checkPkgTrust pkgs = do
    1350 1350 
             errors = S.foldr go emptyBag pkgs
    1351 1351 
             state  = hsc_units hsc_env
    1352 1352 
             go pkg acc
    1353 
    -            | unitIsTrusted $ unsafeLookupUnitId state pkg
    1353 
    +            | isUnitIdTrusted state pkg
    1354 1354 
                 = acc
    1355 1355 
                 | otherwise
    1356 1356 
                 = (`consBag` acc)

  • compiler/GHC/Unit/State.hs
    ... ... @@ -27,6 +27,9 @@ module GHC.Unit.State (
    27 27 
             lookupUnitId,
    28 28 
             lookupUnitId',
    29 29 
             unsafeLookupUnitId,
    30 
    +        isUnitTrusted,
    31 
    +      isUnitIdTrusted,
    32 
    +        isUnitInfoTrusted,
    30 33
    31 34 
             lookupPackageName,
    32 35 
             resolvePackageImport,
    ... ... @@ -433,6 +436,9 @@ data UnitState = UnitState {
    433 436 
       -- may have the 'exposed' flag be 'False'.)
    434 437 
       unitInfoMap :: UnitInfoMap,
    435 438
    439 
    +  trustedUnits :: Set.Set UnitId,
    440 
    +  distrustedUnits :: Set.Set UnitId,
    441 
    +
    436 442 
       -- | The set of transitively reachable units according
    437 443 
       -- to the explicitly provided command line arguments.
    438 444 
       -- A fully instantiated VirtUnit may only be replaced by a RealUnit from
    ... ... @@ -492,6 +498,8 @@ data UnitState = UnitState {
    492 498 
     emptyUnitState :: UnitState
    493 499 
     emptyUnitState = UnitState {
    494 500 
         unitInfoMap    = emptyUniqMap,
    501 
    +    trustedUnits   = Set.empty,
    502 
    +    distrustedUnits = Set.empty,
    495 503 
         preloadClosure = emptyUniqSet,
    496 504 
         packageNameMap = emptyUFM,
    497 505 
         wireMap        = emptyUniqMap,
    ... ... @@ -624,6 +632,21 @@ mkUnitInfoMap infos = foldl' add emptyUniqMap infos
    624 632 
     listUnitInfo :: UnitState -> [UnitInfo]
    625 633 
     listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
    626 634
    635 
    +isUnitTrusted :: HasDebugCallStack => UnitState -> Unit -> Bool
    636 
    +isUnitTrusted ue u =
    637 
    +     Set.member (toUnitId u) (trustedUnits ue) && (Set.notMember (toUnitId u) (distrustedUnits ue))
    638 
    +  || unitIsTrusted (unsafeLookupUnit ue u)
    639 
    +
    640 
    +isUnitIdTrusted :: HasDebugCallStack => UnitState -> UnitId -> Bool
    641 
    +isUnitIdTrusted ue u =
    642 
    +     Set.member u (trustedUnits ue) && (Set.notMember u (distrustedUnits ue))
    643 
    +  || unitIsTrusted (unsafeLookupUnitId ue u)
    644 
    +
    645 
    +isUnitInfoTrusted :: HasDebugCallStack => UnitState -> UnitInfo -> Bool
    646 
    +isUnitInfoTrusted ue unit_info =
    647 
    +     Set.member (unitId unit_info) (trustedUnits ue) && (Set.notMember (unitId unit_info) (distrustedUnits ue))
    648 
    +  || unitIsTrusted unit_info
    649 
    +
    627 650 
     -- ----------------------------------------------------------------------------
    628 651 
     -- Loading the unit db files and building up the unit state
    629 652
    ... ... @@ -852,11 +875,6 @@ readUnitDatabase logger cfg conf_file = do
    852 875 
                  else return (Just []) -- ghc-pkg will create it when it's updated
    853 876 
             else return Nothing
    854 877
    855 
    -distrustAllUnits :: [UnitInfo] -> [UnitInfo]
    856 
    -distrustAllUnits pkgs = map distrust pkgs
    857 
    -  where
    858 
    -    distrust pkg = pkg{ unitIsTrusted = False }
    859 
    -
    860 878 
     mungeUnitInfo :: OsPath -> OsPath
    861 879 
                        -> UnitInfo -> UnitInfo
    862 880 
     mungeUnitInfo top_dir pkgroot =
    ... ... @@ -892,22 +910,28 @@ applyTrustFlag
    892 910 
        :: UnitPrecedenceMap
    893 911 
        -> UnusableUnits
    894 912 
        -> [UnitInfo]
    913 
    +   -> (Set.Set UnitId, Set.Set UnitId)
    895 914 
        -> TrustFlag
    896 
    -   -> MaybeErr UnitErr [UnitInfo]
    897 
    -applyTrustFlag prec_map unusable pkgs flag =
    915 
    +   -> MaybeErr UnitErr (Set.Set UnitId, Set.Set UnitId)
    916 
    +applyTrustFlag prec_map unusable pkgs (trusted, distrusted) flag =
    898 917 
       case flag of
    899 918 
         -- we trust all matching packages. Maybe should only trust first one?
    900 919 
         -- and leave others the same or set them untrusted
    901 920 
         TrustPackage str ->
    902 921 
            case selectPackages prec_map (PackageArg str) pkgs unusable of
    903 922 
              Left ps       -> Failed (TrustFlagErr flag ps)
    904 
    -         Right (ps,qs) -> Succeeded (map trust ps ++ qs)
    905 
    -          where trust p = p {unitIsTrusted=True}
    923 
    +         Right (ps,_) -> Succeeded (insertAll ps trusted, removeAll ps distrusted)
    906 924
    907 925 
         DistrustPackage str ->
    908 926 
            case selectPackages prec_map (PackageArg str) pkgs unusable of
    909 927 
              Left ps       -> Failed (TrustFlagErr flag ps)
    910 
    -         Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)
    928 
    +         Right (ps,_) -> Succeeded (removeAll ps trusted, insertAll ps distrusted)
    929 
    +
    930 
    +insertAll :: [UnitInfo] -> Set UnitId -> Set UnitId
    931 
    +insertAll elements set = foldl' (\ acc -> flip Set.insert acc . unitId) set elements
    932 
    +
    933 
    +removeAll :: [UnitInfo] -> Set UnitId -> Set UnitId
    934 
    +removeAll elements set = foldl' (\ acc -> flip Set.delete acc . unitId) set elements
    911 935
    912 936 
     applyPackageFlag
    913 937 
        :: UnitPrecedenceMap
    ... ... @@ -1547,9 +1571,16 @@ mkUnitState logger cfg = do
    1547 1571 
       raw_dbs <- readUnitDatabases logger cfg
    1548 1572
    1549 1573 
       -- distrust all units if the flag is set
    1550 
    -  let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
    1551 
    -      dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
    1552 
    -          | otherwise                 = raw_dbs
    1574 
    +  let unitsOf db = Set.fromList $ map unitId (unitDatabaseUnits db)
    1575 
    +      allUnits = Set.unions $ map unitsOf raw_dbs
    1576 
    +
    1577 
    +      distrustedUnits
    1578 
    +        | unitConfigDistrustAll cfg = allUnits
    1579 
    +        | otherwise = Set.empty
    1580 
    +
    1581 
    +      trustedUnits = Set.empty
    1582 
    +
    1583 
    +      dbs = raw_dbs
    1553 1584
    1554 1585
    1555 1586 
       -- This, and the other reverse's that you will see, are due to the fact that
    ... ... @@ -1572,11 +1603,12 @@ mkUnitState logger cfg = do
    1572 1603 
       reportCycles   logger sccs
    1573 1604 
       reportUnusable logger unusable
    1574 1605
    1575 
    -  -- Apply trust flags (these flags apply regardless of whether
    1606 
    +  -- Compute trust flags (these flags apply regardless of whether
    1576 1607 
       -- or not packages are visible or not)
    1577 
    -  pkgs1 <- mayThrowUnitErr
    1578 
    -            $ foldM (applyTrustFlag prec_map unusable)
    1579 
    -                 (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
    1608 
    +  (trusted, distrusted) <- mayThrowUnitErr
    1609 
    +            $ foldM (applyTrustFlag prec_map unusable (nonDetEltsUniqMap pkg_map2))
    1610 
    +                 (trustedUnits, distrustedUnits) (reverse (unitConfigFlagsTrusted cfg))
    1611 
    +  let pkgs1 = nonDetEltsUniqMap pkg_map2
    1580 1612 
       let prelim_pkg_db = mkUnitInfoMap pkgs1
    1581 1613
    1582 1614 
       --
    ... ... @@ -1724,6 +1756,8 @@ mkUnitState logger cfg = do
    1724 1756 
              , explicitUnits                = explicit_pkgs
    1725 1757 
              , homeUnitDepends              = home_unit_deps
    1726 1758 
              , unitInfoMap                  = pkg_db
    1759 
    +         , trustedUnits                 = trusted
    1760 
    +         , distrustedUnits              = distrusted
    1727 1761 
              , preloadClosure               = emptyUniqSet
    1728 1762 
              , moduleNameProvidersMap       = mod_map
    1729 1763 
              , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
    ... ... @@ -2170,10 +2204,10 @@ pprUnitsWith pprIPI pkgstate =
    2170 2204 
     -- The idea is to only print package id, and any information that might
    2171 2205 
     -- be different from the package databases (exposure, trust)
    2172 2206 
     pprUnitsSimple :: UnitState -> SDoc
    2173 
    -pprUnitsSimple = pprUnitsWith pprIPI
    2207 
    +pprUnitsSimple ue = pprUnitsWith pprIPI ue
    2174 2208 
         where pprIPI ipi = let i = unitIdFS (unitId ipi)
    2175 2209 
                                e = if unitIsExposed ipi then text "E" else text " "
    2176 
    -                           t = if unitIsTrusted ipi then text "T" else text " "
    2210 
    +                           t = if isUnitInfoTrusted ue ipi then text "T" else text " "
    2177 2211 
                            in e <> t <> text "  " <> ftext i
    2178 2212
    2179 2213 
     -- | Show the mapping of modules to where they come from.

  • ghc/GHCi/UI.hs
    ... ... @@ -2919,11 +2919,11 @@ isSafeModule m = do
    2919 2919
    2920 2920 
         packageTrusted hsc_env md
    2921 2921 
             | isHomeModule (hsc_home_unit hsc_env) md = True
    2922 
    -        | otherwise = unitIsTrusted $ unsafeLookupUnit (hsc_units hsc_env) (moduleUnit md)
    2922 
    +        | otherwise = isUnitTrusted (hsc_units hsc_env) (moduleUnit md)
    2923 2923
    2924 2924 
         tallyPkgs hsc_env deps | not (packageTrustOn dflags) = (S.empty, S.empty)
    2925 2925 
                               | otherwise = S.partition part deps
    2926 
    -        where part pkg   = unitIsTrusted $ unsafeLookupUnitId unit_state pkg
    2926 
    +        where part pkg   = isUnitIdTrusted unit_state pkg
    2927 2927 
                   unit_state = hsc_units hsc_env
    2928 2928 
                   dflags     = hsc_dflags hsc_env
    2929 2929

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help