GitLab

Hannes Siebenhandl pushed to branch wip/fendor/ghc-pkg-faster-closure at Glasgow Haskell Compiler / GHC

Commits:

d320afe7

by fendor at 2026-05-21T10:26:33+02:00

Speed up 'closure' computation in `ghc-pkg`

Cache the set of already seen `UnitId`s and use `Set` operations to
speed up 'closure' computation.

Further simplify the implementation of 'closure' to account for the
actual usage.
As a consequence, we rename 'closure' to 'brokenPackages' to reflect its
purpose better after the simplification.

2 changed files:

+ changelog.d/ghc-pkg-faster-closure
utils/ghc-pkg/Main.hs

Changes:

changelog.d/ghc-pkg-faster-closure

 +section: ghc-pkg
 +synopsis: Improve performance of `ghc-pkg list` command
 +issues: #27275
 +mrs: !16062
++
 +description: {
 +`ghc-pkg list` was quadratic in the number of packages due to an inefficient `closure` computation.
 +We cache the set of seen packages, allowing us to speed up the `closure` computation, improving run-time
 +for the commands `list`, `check`, `distrust`, `expose`, `hide`, `trust` and `unregister`.
 +}

utils/ghc-pkg/Main.hs

@@ -1826,7 +1826,7 @@ checkConsistency verbosity my_flags = do
                all_ps = map mungedId pkgs1
    let not_broken_pkgs = filterOut broken_pkgs pkgs
 -      (_, trans_broken_pkgs) = closure [] not_broken_pkgs
 +      trans_broken_pkgs = brokenPackages not_broken_pkgs
        all_broken_pkgs :: [InstalledPackageInfo]
        all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
@@ -1845,26 +1845,26 @@ checkConsistency verbosity my_flags = do
    when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
 -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 -        -> ([InstalledPackageInfo], [InstalledPackageInfo])
 -closure pkgs db_stack = go pkgs db_stack
 - where
 -   go avail not_avail =
 -     case partition (depsAvailable avail) not_avail of
 -        ([],        not_avail') -> (avail, not_avail')
 -        (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
 +-- | Compute the set of transitive broken packages.
 +--
 +-- A package is assumed to be broken if any of its dependencies is not
 +-- found in the 'db_stack' after a transitive reduction.
 +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 +brokenPackages db_stack = go Set.empty db_stack
 +  where
 +    go avail_ids not_avail =
 +      case partition (depsAvailable avail_ids) not_avail of
 +        ([],        not_avail') -> not_avail'
 +        (new_avail, not_avail') -> go (add new_avail avail_ids) not_avail'
 -   depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
 -                 -> Bool
 -   depsAvailable pkgs_ok pkg = null dangling
 -        where dangling = filter (`notElem` pids) (depends pkg)
 -              pids = map installedUnitId pkgs_ok
 +    add new_avail avail_ids =
 +      foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
 -        -- we want mutually recursive groups of package to show up
 -        -- as broken. (#1750)
 +    depsAvailable :: Set.Set UnitId -> InstalledPackageInfo -> Bool
 +    depsAvailable pids pkg = all (`Set.member` pids) (depends pkg)
 -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
 -brokenPackages pkgs = snd (closure [] pkgs)
 +      -- we want mutually recursive groups of package to show up
 +      -- as broken. (#1750)
  -----------------------------------------------------------------------------
  -- Sanity-check a new package config, and automatically build GHCi libs