Solver: Check for cycles after every step.

Previously, the solver only checked for cycles after it had already found a
solution. That reduced the number of times that it performed the check in the
common case where there were no cycles. However, when there was a cycle, the
solver could spend a lot of time searching subtrees that already had a cyclic
dependency and therefore could not lead to a solution. This is part of
haskell#3824.

Changes in this commit:
- Store the reverse dependency map on all choice nodes in the search tree, so
  that 'detectCyclesPhase' can access it at every step.
- Check for cycles incrementally at every step. Any new cycle must contain the
  current package, so we just check whether the current package is reachable
  from its neighbors.
- If there is a cycle, we convert the map to a graph and find a strongly
  connected component, as before.
- Instead of using the whole strongly connected component as the conflict set,
  we select one cycle. Smaller conflict sets are better for backjumping.
- The incremental cycle detection automatically fixes a bug where the solver
  filtered out the message about cyclic dependencies when it summarized the full
  log. The bug occurred when the failure message was not immediately after the
  line where the solver chose one of the packages involved in the conflict. See
  haskell#4154.

I tried several approaches and compared performance when solving for
packages with different numbers of dependencies. Here are the results. None of
these runs involved any cycles, so they should have only tested the overhead of
cycle checking. I turned off assertions when building cabal.

Index state: index-state(hackage.haskell.org) = 2016-12-03T17:22:05Z
GHC 8.0.1

Runtime in seconds:
Packages                    Search tree depth   Trials   master   This PR   haskell#1      haskell#2
yesod                       343                 3        2.00     2.00      2.13    2.02
yesod gi-glib leksah        744                 3        3.21     3.31      4.10    3.48
phooey                      66                  3        3.48     3.54      3.56    3.57
Stackage nightly snapshot   6791                1        186      193       357     191

Total memory usage in MB, with '+RTS -s':
Packages                                        Trials   master    This PR   haskell#1     haskell#2
yesod                                           1         189       188       188     198
yesod gi-glib leksah                            1         257       257       263     306
Stackage nightly snapshot                       1        1288      1338      1432   12699

haskell#1 - Same as master, but with cycle checking (Data.Graph.stronglyConnComp) after
     every step.
haskell#2 - Store dependencies in Distribution.Compat.Graph in the search tree, and
     check for cycles containing the current package at every step.

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

@@ -70,7 +70,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
  go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs)
  | qpn == qpn' = go g o ngs
  -- we ignore self-dependencies at this point; TODO: more care may be needed
- | qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn 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) (cons' ng () o) ngs
  -- code above is correct; insert/adjust have different arg order
  go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs
@@ -79,6 +79,9 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
 
  cons' = P.cons . forgetCompOpenGoal
 
+ addIfAbsent :: Eq a => a -> [a] -> [a]
+ addIfAbsent x xs = if x `elem` xs then xs else x : xs
+
 -- | Given the current scope, qualify all the package names in the given set of
 -- dependencies and then extend the set of open goals accordingly.
 scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo ->
@@ -125,11 +128,11 @@ addChildren :: BuildState -> TreeF () QGoalReason BuildState
 -- If we have a choice between many goals, we just record the choice in
 -- the tree. We select each open goal in turn, and before we descend, remove
 -- it from the queue of open goals.
-addChildren bs@(BS { rdeps = rds, open = gs, next = Goals })
- | P.null gs = DoneF rds ()
- | otherwise = GoalChoiceF $ P.mapKeys close
- $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
- $ P.splits gs
+addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals })
+ | P.null gs = DoneF rdm ()
+ | otherwise = GoalChoiceF rdm $ P.mapKeys close
+  $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
+  $ P.splits gs
 
 -- If we have already picked a goal, then the choice depends on the kind
 -- of goal.
@@ -142,15 +145,15 @@ addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _
  error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal"
 addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) =
  error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal"
-addChildren bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =
+addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =
  -- If the package does not exist in the index, we construct an emty PChoiceF node for it
  -- After all, we have no choices here. Alternatively, we could immediately construct
  -- a Fail node here, but that would complicate the construction of conflict sets.
  -- We will probably want to give this case special treatment when generating error
  -- messages though.
  case M.lookup pn idx of
- Nothing -> PChoiceF qpn gr (W.fromList [])
- Just pis -> PChoiceF qpn gr (W.fromList (L.map (\ (i, info) ->
+ Nothing -> PChoiceF qpn rdm gr (W.fromList [])
+ Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) ->
  ([], POption i Nothing, bs { next = Instance qpn i info gr }))
  (M.toList pis)))
  -- TODO: data structure conversion is rather ugly here
@@ -159,8 +162,8 @@ addChildren bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q
 -- that is indicated by the flag default.
 --
 -- TODO: Should we include the flag default in the tree?
-addChildren bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
- FChoiceF qfn gr weak m (W.fromList
+addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
+ FChoiceF qfn rdm gr weak m (W.fromList
  [([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
  ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
  where
@@ -172,8 +175,8 @@ addChildren bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FI
 -- the stanza by replacing the False branch with failure) or preferences
 -- (try enabling the stanza if possible by moving the True branch first).
 
-addChildren bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
- SChoiceF qsn gr trivial (W.fromList
+addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
+ SChoiceF qsn rdm gr trivial (W.fromList
  [([0], False, bs { next = Goals }),
  ([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
  where
@@ -218,7 +221,7 @@ addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =
 -- https:/haskell/cabal/issues/2899
 addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)
 -- The only nodes of interest are package nodes
-addLinking ls (PChoiceF qpn@(Q pp pn) gr cs) =
+addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) =
  let linkedCs = fmap (\bs -> Linker bs ls) $
  W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)
  unlinkedCs = W.mapWithKey goP cs
@@ -229,7 +232,7 @@ addLinking ls (PChoiceF qpn@(Q pp pn) gr cs) =
  goP :: POption -> a -> Linker a
  goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls
  goP _ _ = alreadyLinked
- in PChoiceF qpn gr allCs
+ in PChoiceF qpn rdm gr allCs
 addLinking ls t = fmap (\bs -> Linker bs ls) t
 
 linkChoices :: forall a w . LinkingState

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

@@ -1,50 +1,117 @@
+{-# LANGUAGE TypeFamilies #-}
 module Distribution.Solver.Modular.Cycles (
  detectCyclesPhase
  ) where
 
 import Prelude hiding (cycle)
-import Data.Graph (SCC)
-import qualified Data.Graph as Gr
-import qualified Data.Map as Map
+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.Package
 import Distribution.Solver.Modular.Tree
 import qualified Distribution.Solver.Modular.ConflictSet as CS
+import Distribution.Solver.Types.ComponentDeps (Component)
 import Distribution.Solver.Types.PackagePath
 
--- | Find and reject any solutions that are cyclic
+-- | Find and reject any nodes with cyclic dependencies
 detectCyclesPhase :: Tree d c -> Tree d c
 detectCyclesPhase = cata go
  where
- -- The only node of interest is DoneF
+ -- Only check children of choice nodes.
  go :: TreeF d c (Tree d c) -> Tree d c
- go (PChoiceF qpn gr cs) = PChoice qpn gr cs
- go (FChoiceF qfn gr w m cs) = FChoice qfn gr w m cs
- go (SChoiceF qsn gr w cs) = SChoice qsn gr w cs
- go (GoalChoiceF cs) = GoalChoice cs
- go (FailF cs reason) = Fail cs reason
-
- -- We check for cycles only if we have actually found a solution
- -- This minimizes the number of cycle checks we do as cycles are rare
- go (DoneF revDeps s) = do
- case findCycles revDeps of
- Nothing -> Done revDeps s
+ go (PChoiceF qpn rdm gr cs) =
+ PChoice qpn rdm gr $ fmap (checkChild qpn) cs
+ go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m cs) =
+ FChoice qfn rdm gr w m $ fmap (checkChild qpn) cs
+ go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) =
+ SChoice qsn rdm gr w $ fmap (checkChild qpn) cs
+ go x = inn 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 'Done' node in the tree, check
+-- | 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.
-findCycles :: RevDepMap -> Maybe ConflictSet
-findCycles revDeps =
- case cycles of
- [] -> Nothing
- c:_ -> Just $ CS.unions $ map (varToConflictSet . P) c
+--
+-- TODO: The conflict set should also contain flag and stanza variables.
+findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
+findCycles pkg rdm =
+ -- This function has two parts: a faster cycle check that is called at every
+ -- step and a slower calculation of the conflict set.
+ --
+ -- 'hasCycle' checks for cycles incrementally by only looking for cycles
+ -- containing the current package. It searches for cycles in the 'RevDepMap',
+ -- which is the data structure used to store reverse dependencies in the
+ -- search tree. We store the reverse dependencies in a map, because Data.Map
+ -- is smaller and/or has better sharing than Distribution.Compat.Graph.
+ --
+ -- If there is a cycle, we call G.cycles to find a strongly connected
+ -- component. Then we choose one cycle from the component to use for the
+ -- conflict set. Choosing only one cycle can lead to a smaller conflict set,
+ -- such as when a choice to enable testing introduces many cycles at once.
+ -- In that case, all cycles contain the current package and are in one large
+ -- strongly connected component.
+ --
+ if hasCycle
+ then let scc :: G.Graph RevDepMapNode
+ scc = case G.cycles $ revDepMapToGraph rdm of
+ [] -> findCyclesError "cannot find a strongly connected component"
+ c : _ -> G.fromList c
+
+ next :: QPN -> QPN
+ next p = case G.neighbors scc p of
+ Just (n : _) -> G.nodeKey n
+ _ -> findCyclesError "cannot find next node in the cycle"
+
+ oneCycle :: [QPN]
+ oneCycle = case iterate next pkg of
+ [] -> findCyclesError "empty cycle"
+ x : xs -> x : takeWhile (/= x) xs
+ in Just $ CS.fromList $ map P oneCycle
+ else Nothing
  where
- cycles :: [[QPN]]
- cycles = [vs | Gr.CyclicSCC vs <- scc]
+ hasCycle :: Bool
+ hasCycle = pkg `elem` closure (neighbors pkg)
+
+ closure :: [QPN] -> S.Set QPN
+ closure = foldl go S.empty
+ where
+ go :: S.Set QPN -> QPN -> S.Set QPN
+ go s x =
+ if x `S.member` s
+ then s
+ else foldl go (S.insert x s) $ neighbors x
+
+ neighbors :: QPN -> [QPN]
+ neighbors x = case x `M.lookup` 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)]
 
- scc :: [SCC QPN]
- scc = Gr.stronglyConnComp . map aux . Map.toList $ revDeps
+instance G.IsNode RevDepMapNode where
+ type Key RevDepMapNode = QPN
+ nodeKey (RevDepMapNode qpn _) = qpn
+ nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns
 
- aux :: (QPN, [(comp, QPN)]) -> (QPN, QPN, [QPN])
- aux (fr, to) = (fr, fr, map snd to)
+revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
+revDepMapToGraph rdm = G.fromList
+ [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]

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

@@ -94,15 +94,15 @@ assign tree = cata go tree $ A M.empty M.empty M.empty
  where
  go :: TreeF d c (Assignment -> Tree Assignment c)
  -> (Assignment -> Tree Assignment c)
- go (FailF c fr) _ = Fail c fr
- go (DoneF rdm _) a = Done rdm a
- go (PChoiceF qpn y ts) (A pa fa sa) = PChoice qpn y $ W.mapWithKey f ts
+ go (FailF c fr) _  = Fail c fr
+ go (DoneF rdm _) a  = Done rdm a
+ go (PChoiceF qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f ts
  where f (POption k _) r = r (A (M.insert qpn k pa) fa sa)
- go (FChoiceF qfn y t m ts) (A pa fa sa) = FChoice qfn y t m $ W.mapWithKey f ts
+ go (FChoiceF qfn rdm y t m ts) (A pa fa sa) = FChoice qfn rdm y t m $ W.mapWithKey f ts
  where f k r = r (A pa (M.insert qfn k fa) sa)
- go (SChoiceF qsn y t ts) (A pa fa sa) = SChoice qsn y t $ W.mapWithKey f ts
+ go (SChoiceF qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f ts
  where f k r = r (A pa fa (M.insert qsn k sa))
- go (GoalChoiceF ts) a = GoalChoice $ fmap ($ a) ts
+ go (GoalChoiceF rdm  ts) a = GoalChoice rdm $ fmap ($ a) ts
 
 -- | A tree traversal that simultaneously propagates conflict sets up
 -- the tree from the leaves and creates a log.
@@ -120,22 +120,22 @@ exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
  go (FailF c fr) = \ !cm -> failWith (Failure c fr)
  (c, updateCM c cm)
  go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm)
- go (PChoiceF qpn gr ts)  =
+ go (PChoiceF qpn _ gr ts) =
  backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
  W.mapWithKey -- when descending ...
  (\ k r cm -> tryWith (TryP qpn k) (r cm))
  ts
- go (FChoiceF qfn gr _ _ ts)  =
+ go (FChoiceF qfn _ gr _ _ ts) =
  backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
  W.mapWithKey -- when descending ...
  (\ k r cm -> tryWith (TryF qfn k) (r cm))
  ts
- go (SChoiceF qsn gr _ ts)  =
+ go (SChoiceF qsn _ gr _ ts) =
  backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
  W.mapWithKey -- when descending ...
  (\ k r cm -> tryWith (TryS qsn k) (r cm))
  ts
- go (GoalChoiceF   ts) = \ cm ->
+ go (GoalChoiceF _ ts) = \ cm ->
  let (k, v) = getBestGoal' ts cm
  in continueWith (Next k) (v cm)
 

cabal-install/Distribution/Solver/Modular/Linking.hs

@@ -74,15 +74,15 @@ validateLinking index = (`runReader` initVS) . cata go
  where
  go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
 
- go (PChoiceF qpn gr cs) =
- PChoice qpn gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
- go (FChoiceF qfn gr t m cs) =
- FChoice qfn gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)
- go (SChoiceF qsn gr t cs) =
- SChoice qsn gr t <$> T.sequence (W.mapWithKey (goS qsn) cs)
+ go (PChoiceF qpn rdm gr cs) =
+ PChoice qpn rdm gr <$> T.sequence (W.mapWithKey (goP qpn) cs)
+ go (FChoiceF qfn rdm gr t m cs) =
+ FChoice qfn rdm gr t m <$> T.sequence (W.mapWithKey (goF qfn) cs)
+ go (SChoiceF qsn rdm gr t cs) =
+ SChoice qsn rdm gr t <$> T.sequence (W.mapWithKey (goS qsn) cs)
 
  -- For the other nodes we just recurse
- go (GoalChoiceF  cs)  = GoalChoice   <$> T.sequence cs
+ go (GoalChoiceF rdm cs) = GoalChoice rdm <$> T.sequence cs
  go (DoneF revDepMap s) = return $ Done revDepMap s
  go (FailF conflictSet failReason) = return $ Fail conflictSet failReason