GitLab

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

Commits:

38ba8673

by fendor at 2026-05-19T12:35:08+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.

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

@@ -1847,21 +1847,28 @@ checkConsistency verbosity my_flags = do
  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'
+-
 -   depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
 -                 -> Bool
 -   depsAvailable pkgs_ok pkg = null dangling
 -        where dangling = filter (`notElem` pids) (depends pkg)
 -              pids = map installedUnitId pkgs_ok
+-
 -        -- we want mutually recursive groups of package to show up
 -        -- as broken. (#1750)
 +closure pkgs db_stack = go (pkgs, pkg_ids) db_stack
 +  where
 +    pkg_ids = Set.fromList $ map installedUnitId pkgs
 +    go (avail, avail_ids) not_avail =
 +      case partition (depsAvailable avail_ids) not_avail of
 +        ([],        not_avail') ->
 +          (avail, not_avail')
 +        (new_avail, not_avail') ->
 +          let
 +            all_pkg_ids =
 +              foldl' (flip Set.insert) avail_ids (map installedUnitId new_avail)
 +          in
 +            go (new_avail ++ avail, all_pkg_ids) not_avail'
++
++
 +    depsAvailable :: Set.Set UnitId -> InstalledPackageInfo
 +                  -> Bool
 +    depsAvailable pids pkg = null dangling
 +      where dangling = filter (`Set.notMember` pids) (depends pkg)
++
 +      -- we want mutually recursive groups of package to show up
 +      -- as broken. (#1750)
  brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
  brokenPackages pkgs = snd (closure [] pkgs)