Redesign private scope closure check for performance

Redesigns the algorithm for checking the private scope closure property
in the solver.

The algorithm is described in detail in the comment of
`findBadPrivClosures`. A key change is that we construct and propagate
together with the `RevDepMap` a cache of the private scopes at every
node, which allow us to efficiently look up the "root" packages from
which we can easily validate the property holds.

This change was prompted by stress testing private dependencies:
The stress test uncovered that way too much time was being spent on
validating the closure property, despite the property already being
checked at every node.

Specifically, the baseline for solving without
the check was 11s, however, with the check in place, solving instead
took over 50s when NO private dependencies were in the plan, and over 2
minutes when there were a lot of private scopes.

After this change, the check of the private scope closure property is
negligible on performance, being slightly faster (40ms) when there are a
lot of private scopes (because the algorithm short circuits faster) and
slightly slower (90ms) when there are no private scopes at all. This is
more in line with the `findCycles` check takes some 110ms on my machine.

This commit also adds the stress test which uncovered the problem,
however, this stress test is disabled by default and should only be run
manually since testing time-based performance in CI can be problematic.

cabal-install-solver/cabal-install-solver.cabal

@@ -72,6 +72,7 @@ library
     Distribution.Solver.Modular.Solver
     Distribution.Solver.Modular.Tree
     Distribution.Solver.Modular.Validate
+    Distribution.Solver.Modular.ValidateDependencies
     Distribution.Solver.Modular.Var
     Distribution.Solver.Modular.Version
     Distribution.Solver.Modular.WeightedPSQ

cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs

@@ -54,7 +54,7 @@ toCPs (A pa fa sa) rdm =
     cvm :: QPN -> Maybe Vertex
     -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
     (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))
-                                  (M.toList rdm))
+                                  (M.toList $ revDeps rdm))
     tg :: Graph Component
     tg = transposeG g
     -- Topsort the dependency graph, yielding a list of pkgs in the right order.

cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs

@@ -81,10 +81,19 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
             -- instance for the setup script. We may need to track other
             -- self-dependencies once we implement component-based solving.
           case c of
-            ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs
+            ComponentSetup -> go g{revDeps = M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn (revDeps g)} o ngs
             _              -> go                                                    g  o ngs
-      | qpn `M.member` g  = go (M.adjust (addIfAbsent (c, qpn')) qpn g)   o  ngs
-      | otherwise         = go (M.insert qpn [(c, qpn')]  g) (PkgGoal qpn (DependencyGoal dr) : o) ngs
+      | qpn `M.member` (revDeps g)
+      = go g{ revDeps = M.adjust (addIfAbsent (c, qpn')) qpn (revDeps g)
+            -- If qpn is already a member of revDeps, it is already in the privScopes mapping.
+            } o ngs
+      | otherwise
+      = go g{ revDeps = M.insert qpn [(c, qpn')]  (revDeps g)
+            , privScopes = case qpn of
+                Q (PackagePath _ ql@QualAlias{}) _ ->
+                  M.insertWith(<>) ql (S.singleton qpn) (privScopes g)
+                _ -> privScopes g
+            } (PkgGoal qpn (DependencyGoal dr) : o) ngs
           -- code above is correct; insert/adjust have different arg order
     go g o ((Simple (LDep _dr (Ext _ext )) _)  : ngs) = go g o ngs
     go g o ((Simple (LDep _dr (Lang _lang))_)  : ngs) = go g o ngs
@@ -252,7 +261,7 @@ buildTree idx (IndependentGoals ind) igs =
     build Linker {
         buildState = BS {
             index = idx
-          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)
+          , rdeps = RevDepMap { revDeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns), privScopes = mempty }
           , open  = L.map topLevelGoal qpns
           , next  = Goals
           , qualifyOptions = defaultQualifyOptions idx

cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs

@@ -74,15 +74,6 @@ data Conflict =
     -- means that package y's constraint 'x >= 2.0' excluded some version of x.
   | VersionConflict QPN OrderedVersionRange
 
-    -- | The conflict set variable represents a package that was excluded for
-    -- violating the closure property of a private-scope, because that package is part of
-    -- the closure of the private scope, but it itself is not
-    -- included in it. For example, the conflict set entry '(P pkgC,
-    -- PrivateScopeClosureConflict pkgA:lib:G0:pkgB pkgA:lib:G0:pkgD)' means
-    -- that pkgC is in the (private-deps) closure from pkgA:lib:G0:pkgB to
-    -- pkgA:lib:G0:pkgD, but pkgC is not included in the private scope pkgA:lib:G0.
-  | PrivateScopeClosureConflict QPN QPN
-
     -- | Any other conflict.
   | OtherConflict
   deriving (Eq, Ord, Show)

cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs

@@ -1,58 +1,28 @@
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 module Distribution.Solver.Modular.Cycles (
-    detectCyclesPhase
+    findCycles
   ) where
 
 import Prelude hiding (cycle)
 import qualified Data.Map as M
 import qualified Data.Set as S
 
 import qualified Distribution.Compat.Graph as G
-import Distribution.Simple.Utils (ordNub)
 import Distribution.Solver.Modular.Dependency
-import Distribution.Solver.Modular.Flag
 import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.ConflictSet as CS
-import Distribution.Solver.Types.ComponentDeps (Component)
 import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Modular.ValidateDependencies
 
--- | Find and reject any nodes with cyclic dependencies
-detectCyclesPhase :: Tree d c -> Tree d c
-detectCyclesPhase = go
-  where
-    -- Only check children of choice nodes.
-    go :: Tree d c -> Tree d c
-    go (PChoice qpn rdm gr                         cs) =
-        PChoice qpn rdm gr     $ fmap (checkChild qpn)   (fmap go cs)
-    go (FChoice qfn@(FN qpn _) rdm gr w m d cs) =
-        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs)
-    go (SChoice qsn@(SN qpn _) rdm gr w     cs) =
-        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   (fmap go cs)
-    go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs)
-    go x@(Fail _ _) = x
-    go x@(Done _ _) = x
-
-    checkChild :: QPN -> Tree d c -> Tree d c
-    checkChild qpn x@(PChoice _  rdm _       _) = failIfCycle qpn rdm x
-    checkChild qpn x@(FChoice _  rdm _ _ _ _ _) = failIfCycle qpn rdm x
-    checkChild qpn x@(SChoice _  rdm _ _     _) = failIfCycle qpn rdm x
-    checkChild qpn x@(GoalChoice rdm         _) = failIfCycle qpn rdm x
-    checkChild _   x@(Fail _ _)                 = x
-    checkChild qpn x@(Done       rdm _)         = failIfCycle qpn rdm x
-
-    failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c
-    failIfCycle qpn rdm x =
-      case findCycles qpn rdm of
-        Nothing     -> x
-        Just relSet -> Fail relSet CyclicDependencies
 
 -- | Given the reverse dependency map from a node in the tree, check
 -- if the solution is cyclic. If it is, return the conflict set containing
 -- all decisions that could potentially break the cycle.
 --
 -- TODO: The conflict set should also contain flag and stanza variables.
-findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
-findCycles pkg rdm =
+findCycles :: QPN -> RevDepMap -> Maybe (ConflictSet, FailReason)
+findCycles pkg rdm = (,CyclicDependencies) <$>
     -- This function has two parts: a faster cycle check that is called at every
     -- step and a slower calculation of the conflict set.
     --
@@ -102,19 +72,9 @@ findCycles pkg rdm =
             else foldl go (S.insert x s) $ neighbors x
 
     neighbors :: QPN -> [QPN]
-    neighbors x = case x `M.lookup` rdm of
+    neighbors x = case x `M.lookup` revDeps rdm of
                     Nothing -> findCyclesError "cannot find node"
                     Just xs -> map snd xs
 
     findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++)
 
-data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]
-
-instance G.IsNode RevDepMapNode where
-  type Key RevDepMapNode = QPN
-  nodeKey (RevDepMapNode qpn _) = qpn
-  nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns
-
-revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
-revDepMapToGraph rdm = G.fromDistinctList
-                       [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]

cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs

@@ -25,7 +25,7 @@ module Distribution.Solver.Modular.Dependency (
   , qualifyDeps
   , unqualifyDeps
     -- * Reverse dependency map
-  , RevDepMap
+  , RevDepMap(..)
     -- * Goals
   , Goal(..)
   , GoalReason(..)
@@ -226,7 +226,7 @@ qualifyDeps QO{..} rdm (Q pp@(PackagePath ns q) pn) = go
                      -- with the package-path of the package that introduced
                      -- this dependency, which will match if this dependency is
                      -- included in the same private scope.
-                     case M.lookup (Q pp pnx) rdm of
+                     case M.lookup (Q pp pnx) (revDeps rdm) of
                        Just _x -> q -- found, use same private qualifier
                        Nothing -> QualToplevel -- not found, use top level qual
 
@@ -268,7 +268,12 @@ unqualifyDeps = go
 
 -- | A map containing reverse dependencies between qualified
 -- package names.
-type RevDepMap = Map QPN [(Component, QPN)]
+data RevDepMap = RevDepMap
+  { revDeps :: Map QPN [(Component, QPN)]
+    -- ^ The reverse dependencies
+  , privScopes :: Map Qualifier {- a private qualifier -} (S.Set QPN) {- caches the packages in this private scope -}
+    -- ^ Information related to reverse dependency mapped additionally cached here.
+  }
 
 {-------------------------------------------------------------------------------
   Goals

cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs

@@ -274,7 +274,6 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx
 
           couldBeResolved :: CS.Conflict -> Maybe ConflictSet
           couldBeResolved CS.OtherConflict = Nothing
-          couldBeResolved (CS.PrivateScopeClosureConflict _ _) = Nothing -- Could we optimise here?
           couldBeResolved (CS.GoalConflict conflictingDep) =
               -- Check whether this package instance also has 'conflictingDep'
               -- as a dependency (ignoring flag and stanza choices).

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -181,7 +181,6 @@ showConflicts conflicts =
             Just (qpn, MergedPackageConflict False [v] Nothing)
         toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =
             Just (qpn, MergedPackageConflict False [] (Just vr))
-        toMergedConflict (CS.PrivateScopeClosureConflict _ _) = Nothing
         toMergedConflict CS.OtherConflict = Nothing
 
     showConflict :: QPN -> MergedPackageConflict -> String
@@ -303,7 +302,7 @@ showFR c Backjump                         = " (backjumping, conflict set: " ++ s
 showFR _ MultipleInstances                = " (multiple instances)"
 showFR c (DependenciesNotLinked msg)      = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")"
 showFR c CyclicDependencies               = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")"
-showFR c (InvalidPrivateScope qual)       = " (private scopes must contain its closure, but package " ++ showConflictSet c ++ " is not included in the private scope " ++ prettyShow qual ++ ")"
+showFR c (InvalidPrivateScope qual)       = " (private scopes must contain its closure, but packages " ++ showConflictSet c ++ " are not included in the private scope " ++ prettyShow qual ++ ")"
 showFR _ (UnsupportedSpecVer ver)         = " (unsupported spec-version " ++ prettyShow ver ++ ")"
 -- The following are internal failures. They should not occur. In the
 -- interest of not crashing unnecessarily, we still just print an error