From fc3079d42b981b7a2a4f1db57cc545ab220254bb Mon Sep 17 00:00:00 2001 From: Kristen Kozak Date: Sun, 18 Dec 2016 20:30:32 -0800 Subject: [PATCH] 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 https://github.com/haskell/cabal/issues/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 https://github.com/haskell/cabal/issues/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 #1 #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 #1 #2 yesod 1 189 188 188 198 yesod gi-glib leksah 1 257 257 263 306 Stackage nightly snapshot 1 1288 1338 1432 12699 #1 - Same as master, but with cycle checking (Data.Graph.stronglyConnComp) after every step. #2 - Store dependencies in Distribution.Compat.Graph in the search tree, and check for cycles containing the current package at every step. --- .../Distribution/Solver/Modular/Builder.hs | 33 ++--- .../Distribution/Solver/Modular/Cycles.hs | 123 ++++++++++++++---- .../Distribution/Solver/Modular/Explore.hs | 20 +-- .../Distribution/Solver/Modular/Linking.hs | 14 +- .../Distribution/Solver/Modular/Preference.hs | 74 +++++------ .../Distribution/Solver/Modular/Solver.hs | 40 ++---- .../Distribution/Solver/Modular/Tree.hs | 78 +++++------ .../Distribution/Solver/Modular/Validate.hs | 16 +-- 8 files changed, 226 insertions(+), 172 deletions(-) diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs index de23825107b..474a51ca6ef 100644 --- a/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/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://github.com/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 diff --git a/cabal-install/Distribution/Solver/Modular/Cycles.hs b/cabal-install/Distribution/Solver/Modular/Cycles.hs index 722f8ac058f..a9309a079aa 100644 --- a/cabal-install/Distribution/Solver/Modular/Cycles.hs +++ b/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] diff --git a/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal-install/Distribution/Solver/Modular/Explore.hs index 95e2c6614f6..027c1ce0d37 100644 --- a/cabal-install/Distribution/Solver/Modular/Explore.hs +++ b/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) diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs index f4b07ef3b00..92101c2b843 100644 --- a/cabal-install/Distribution/Solver/Modular/Linking.hs +++ b/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 diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index d80ab01fb97..1891bcf6aa5 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -53,13 +53,13 @@ addWeights :: [PN -> [Ver] -> POption -> Weight] -> Tree d c -> Tree d c addWeights fs = trav go where go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) - go (PChoiceF qpn@(Q _ pn) x cs) = + go (PChoiceF qpn@(Q _ pn) rdm x cs) = let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) weights k = [f pn sortedVersions k | f <- fs] elemsToWhnf :: [a] -> () elemsToWhnf = foldr seq () - in PChoiceF qpn x + in PChoiceF qpn rdm x -- Evaluate the children's versions before evaluating any of the -- subtrees, so that 'sortedVersions' doesn't hold onto all of the -- subtrees (referenced by cs) and cause a space leak. @@ -128,13 +128,13 @@ preferPackagePreferences pcs = preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c preferPackageStanzaPreferences pcs = trav go where - go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) gr _tr ts) + go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) rdm gr _tr ts) | primaryPP pp && enableStanzaPref pn s = -- move True case first to try enabling the stanza let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts weight k = if k then 0 else 1 -- defer the choice by setting it to weak - in SChoiceF qsn gr (WeakOrTrivial True) ts' + in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' go x = x enableStanzaPref :: PN -> OptionalStanza -> Bool @@ -214,24 +214,24 @@ enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] -> Tree d c enforcePackageConstraints pcs = trav go where - go (PChoiceF qpn@(Q pp pn) gr ts) = + go (PChoiceF qpn@(Q pp pn) rdm gr ts) = let c = varToConflictSet (P qpn) -- compose the transformation functions for each of the relevant constraint g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP pp c i pc) id (M.findWithDefault [] pn pcs) - in PChoiceF qpn gr (W.mapWithKey g ts) - go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = + in PChoiceF qpn rdm gr (W.mapWithKey g ts) + go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) rdm gr tr m ts) = let c = varToConflictSet (F qfn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id (M.findWithDefault [] pn pcs) - in FChoiceF qfn gr tr m (W.mapWithKey g ts) - go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = + in FChoiceF qfn rdm gr tr m (W.mapWithKey g ts) + go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) rdm gr tr ts) = let c = varToConflictSet (S qsn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id (M.findWithDefault [] pn pcs) - in SChoiceF qsn gr tr (W.mapWithKey g ts) + in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) go x = x -- | Transformation that tries to enforce manual flags. Manual flags @@ -242,7 +242,7 @@ enforcePackageConstraints pcs = trav go enforceManualFlags :: Tree d c -> Tree d c enforceManualFlags = trav go where - go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $ + go (FChoiceF qfn rdm gr tr True ts) = FChoiceF qfn rdm gr tr True $ let c = varToConflictSet (F qfn) in case span isDisabled (W.toList ts) of ([], y : ys) -> W.fromList (y : L.map (\ (w, b, _) -> (w, b, Fail c ManualFlag)) ys) @@ -256,9 +256,9 @@ enforceManualFlags = trav go requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c requireInstalled p = trav go where - go (PChoiceF v@(Q _ pn) gr cs) - | p pn = PChoiceF v gr (W.mapWithKey installed cs) - | otherwise = PChoiceF v gr cs + go (PChoiceF v@(Q _ pn) rdm gr cs) + | p pn = PChoiceF v rdm gr (W.mapWithKey installed cs) + | otherwise = PChoiceF v rdm gr cs where installed (POption (I _ (Inst _)) _) x = x installed _ _ = Fail (varToConflictSet (P v)) CannotInstall @@ -280,9 +280,9 @@ requireInstalled p = trav go avoidReinstalls :: (PN -> Bool) -> Tree d c -> Tree d c avoidReinstalls p = trav go where - go (PChoiceF qpn@(Q _ pn) gr cs) - | p pn = PChoiceF qpn gr disableReinstalls - | otherwise = PChoiceF qpn gr cs + go (PChoiceF qpn@(Q _ pn) rdm gr cs) + | p pn = PChoiceF qpn rdm gr disableReinstalls + | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] @@ -298,8 +298,8 @@ avoidReinstalls p = trav go sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c sortGoals variableOrder = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys goalOrder xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) + go x = x goalOrder :: Goal QPN -> Goal QPN -> Ordering goalOrder = variableOrder `on` (varToVariable . goalToVar) @@ -318,8 +318,8 @@ sortGoals variableOrder = trav go firstGoal :: Tree d c -> Tree d c firstGoal = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) + go x = x -- Note that we keep empty choice nodes, because they mean success. -- | Transformation that tries to make a decision on base as early as @@ -329,8 +329,8 @@ firstGoal = trav go preferBaseGoalChoice :: Tree d c -> Tree d c preferBaseGoalChoice = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.filterIfAnyByKeys isBase xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) + go x = x isBase :: Goal QPN -> Bool isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" @@ -341,8 +341,8 @@ preferBaseGoalChoice = trav go deferSetupChoices :: Tree d c -> Tree d c deferSetupChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs) + go x = x noSetup :: Goal QPN -> Bool noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False @@ -354,16 +354,16 @@ deferSetupChoices = trav go deferWeakFlagChoices :: Tree d c -> Tree d c deferWeakFlagChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) + go x = x noWeakStanza :: Tree d c -> Bool - noWeakStanza (SChoice _ _ (WeakOrTrivial True) _) = False - noWeakStanza _ = True + noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False + noWeakStanza _ = True noWeakFlag :: Tree d c -> Bool - noWeakFlag (FChoice _ _ (WeakOrTrivial True) _ _) = False - noWeakFlag _ = True + noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _) = False + noWeakFlag _ = True -- | Transformation that sorts choice nodes so that -- child nodes with a small branching degree are preferred. @@ -386,10 +386,10 @@ deferWeakFlagChoices = trav go preferEasyGoalChoices :: Tree d c -> Tree d c preferEasyGoalChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs) + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.dminimumBy dchoices xs) -- (a different implementation that seems slower): -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs)) - go x = x + go x = x -- | A variant of 'preferEasyGoalChoices' that just keeps the -- ones with a branching degree of 0 or 1. Note that unlike @@ -399,8 +399,8 @@ preferEasyGoalChoices = trav go preferReallyEasyGoalChoices :: Tree d c -> Tree d c preferReallyEasyGoalChoices = trav go where - go (GoalChoiceF xs) = GoalChoiceF (P.filterIfAny zeroOrOneChoices xs) - go x = x + go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) + go x = x -- | Monad used internally in enforceSingleInstanceRestriction -- @@ -420,8 +420,8 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c) -- We just verify package choices. - go (PChoiceF qpn gr cs) = - PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) cs) + go (PChoiceF qpn rdm gr cs) = + PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) cs) go _otherwise = innM _otherwise diff --git a/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal-install/Distribution/Solver/Modular/Solver.hs index c678147037f..08b397737eb 100644 --- a/cabal-install/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/Distribution/Solver/Modular/Solver.hs @@ -75,22 +75,6 @@ data SolverConfig = SolverConfig { -- has been added relatively recently. Cycles are only removed directly -- before exploration. -- --- Semantically, there is no difference. Cycle detection, as implemented --- now, only occurs for 'Done' nodes we encounter during exploration, --- and cycle detection itself does not change the shape of the tree, --- it only marks some 'Done' nodes as 'Fail', if they contain cyclic --- solutions. --- --- There is a tiny performance impact, however, in doing cycle detection --- directly after validation. Probably because cycle detection maintains --- some information, and the various reorderings implemented by --- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more --- costly if that information is already around during the reorderings. --- --- With the current positioning directly before the 'explorePhase', there --- seems to be no statistically significant performance impact of cycle --- detection in the common case where there are no cycles. --- solve :: SolverConfig -- ^ solver parameters -> CompilerInfo -> Index -- ^ all available packages as an index @@ -177,12 +161,12 @@ instance GSimpleTree (Tree d c) where fromGeneric = go where go :: Tree d c -> SimpleTree - go (PChoice qpn _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq - go (FChoice _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (SChoice _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (GoalChoice psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq - go (Done _rdm _s) = Node "D" $ Assoc [] - go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] + go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq + go (FChoice _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq + go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq + go (Done _rdm _s) = Node "D" $ Assoc [] + go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] psqToList :: W.WeightedPSQ w k v -> [(k, v)] psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList @@ -222,12 +206,12 @@ _removeGR :: Tree d c -> Tree d QGoalReason _removeGR = trav go where go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) - go (PChoiceF qpn _ psq) = PChoiceF qpn dummy psq - go (FChoiceF qfn _ a b psq) = FChoiceF qfn dummy a b psq - go (SChoiceF qsn _ a psq) = SChoiceF qsn dummy a psq - go (GoalChoiceF psq) = GoalChoiceF (goG psq) - go (DoneF rdm s) = DoneF rdm s - go (FailF cs reason) = FailF cs reason + go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq + go (FChoiceF qfn rdm _ a b psq) = FChoiceF qfn rdm dummy a b psq + go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq + go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) + go (DoneF rdm s) = DoneF rdm s + go (FailF cs reason) = FailF cs reason goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) goG = PSQ.fromList diff --git a/cabal-install/Distribution/Solver/Modular/Tree.hs b/cabal-install/Distribution/Solver/Modular/Tree.hs index 3e3bab9d418..b3d301967d1 100644 --- a/cabal-install/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install/Distribution/Solver/Modular/Tree.hs @@ -45,15 +45,15 @@ type Weight = Double -- giving too much weight to preferences that are applied later. data Tree d c = -- | Choose a version for a package (or choose to link) - PChoice QPN c (WeightedPSQ [Weight] POption (Tree d c)) + PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) -- | Choose a value for a flag -- -- The Bool indicates whether it's manual. - | FChoice QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c)) + | FChoice QFN RevDepMap c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose whether or not to enable a stanza - | SChoice QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose which choice to make next -- @@ -66,7 +66,7 @@ data Tree d c = -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice (PSQ (Goal QPN) (Tree d c)) + | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) -- | We're done -- we found a solution! | Done RevDepMap d @@ -117,37 +117,37 @@ data FailReason = InconsistentInitialConstraints -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- have the same meaning as in 'Tree'. data TreeF d c a = - PChoiceF QPN c (WeightedPSQ [Weight] POption a) - | FChoiceF QFN c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool a) - | SChoiceF QSN c WeakOrTrivial (WeightedPSQ [Weight] Bool a) - | GoalChoiceF (PSQ (Goal QPN) a) - | DoneF RevDepMap d + PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) + | FChoiceF QFN RevDepMap c WeakOrTrivial Bool (WeightedPSQ [Weight] Bool a) + | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) + | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) + | DoneF RevDepMap d | FailF ConflictSet FailReason deriving (Functor, Foldable, Traversable) out :: Tree d c -> TreeF d c (Tree d c) -out (PChoice p i ts) = PChoiceF p i ts -out (FChoice p i b m ts) = FChoiceF p i b m ts -out (SChoice p i b ts) = SChoiceF p i b ts -out (GoalChoice ts) = GoalChoiceF ts -out (Done x s ) = DoneF x s -out (Fail c x ) = FailF c x +out (PChoice p s i ts) = PChoiceF p s i ts +out (FChoice p s i b m ts) = FChoiceF p s i b m ts +out (SChoice p s i b ts) = SChoiceF p s i b ts +out (GoalChoice s ts) = GoalChoiceF s ts +out (Done x s ) = DoneF x s +out (Fail c x ) = FailF c x inn :: TreeF d c (Tree d c) -> Tree d c -inn (PChoiceF p i ts) = PChoice p i ts -inn (FChoiceF p i b m ts) = FChoice p i b m ts -inn (SChoiceF p i b ts) = SChoice p i b ts -inn (GoalChoiceF ts) = GoalChoice ts -inn (DoneF x s ) = Done x s -inn (FailF c x ) = Fail c x +inn (PChoiceF p s i ts) = PChoice p s i ts +inn (FChoiceF p s i b m ts) = FChoice p s i b m ts +inn (SChoiceF p s i b ts) = SChoice p s i b ts +inn (GoalChoiceF s ts) = GoalChoice s ts +inn (DoneF x s ) = Done x s +inn (FailF c x ) = Fail c x innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) -innM (PChoiceF p i ts) = liftM (PChoice p i ) (sequence ts) -innM (FChoiceF p i b m ts) = liftM (FChoice p i b m) (sequence ts) -innM (SChoiceF p i b ts) = liftM (SChoice p i b ) (sequence ts) -innM (GoalChoiceF ts) = liftM (GoalChoice ) (sequence ts) -innM (DoneF x s ) = return $ Done x s -innM (FailF c x ) = return $ Fail c x +innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) +innM (FChoiceF p s i b m ts) = liftM (FChoice p s i b m) (sequence ts) +innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) +innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) +innM (DoneF x s ) = return $ Done x s +innM (FailF c x ) = return $ Fail c x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree d c -> Bool @@ -157,21 +157,21 @@ active _ = True -- | Approximates the number of active choices that are available in a node. -- Note that we count goal choices as having one choice, always. dchoices :: Tree d c -> Degree -dchoices (PChoice _ _ ts) = W.degree (W.filter active ts) -dchoices (FChoice _ _ _ _ ts) = W.degree (W.filter active ts) -dchoices (SChoice _ _ _ ts) = W.degree (W.filter active ts) -dchoices (GoalChoice _ ) = ZeroOrOne -dchoices (Done _ _ ) = ZeroOrOne -dchoices (Fail _ _ ) = ZeroOrOne +dchoices (PChoice _ _ _ ts) = W.degree (W.filter active ts) +dchoices (FChoice _ _ _ _ _ ts) = W.degree (W.filter active ts) +dchoices (SChoice _ _ _ _ ts) = W.degree (W.filter active ts) +dchoices (GoalChoice _ _ ) = ZeroOrOne +dchoices (Done _ _ ) = ZeroOrOne +dchoices (Fail _ _ ) = ZeroOrOne -- | Variant of 'dchoices' that traverses fewer children. zeroOrOneChoices :: Tree d c -> Bool -zeroOrOneChoices (PChoice _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (FChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (SChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) -zeroOrOneChoices (GoalChoice _ ) = True -zeroOrOneChoices (Done _ _ ) = True -zeroOrOneChoices (Fail _ _ ) = True +zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (FChoice _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) +zeroOrOneChoices (GoalChoice _ _ ) = True +zeroOrOneChoices (Done _ _ ) = True +zeroOrOneChoices (Fail _ _ ) = True -- | Catamorphism on trees. cata :: (TreeF d c a -> a) -> Tree d c -> a diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index 678836de707..f35a9533f08 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -106,8 +106,8 @@ validate = cata go where go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c) - go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (W.mapWithKey (goP qpn) ts) - go (FChoiceF qfn gr b m ts) = + go (PChoiceF qpn rdm gr ts) = PChoice qpn rdm gr <$> sequence (W.mapWithKey (goP qpn) ts) + go (FChoiceF qfn rdm gr b m ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby @@ -119,8 +119,8 @@ validate = cata go Just t -> goF qfn rb t Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches - FChoice qfn gr b m <$> sequence (W.mapWithKey (goF qfn) ts) - go (SChoiceF qsn gr b ts) = + FChoice qfn rdm gr b m <$> sequence (W.mapWithKey (goF qfn) ts) + go (SChoiceF qsn rdm gr b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment @@ -130,12 +130,12 @@ validate = cata go Just t -> goS qsn rb t Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) Nothing -> -- stanza choice is new, follow both branches - SChoice qsn gr b <$> sequence (W.mapWithKey (goS qsn) ts) + SChoice qsn rdm gr b <$> sequence (W.mapWithKey (goS qsn) ts) -- We don't need to do anything for goal choices or failure nodes. - go (GoalChoiceF ts) = GoalChoice <$> sequence ts - go (DoneF rdm s ) = pure (Done rdm s) - go (FailF c fr ) = pure (Fail c fr) + go (GoalChoiceF rdm ts) = GoalChoice rdm <$> sequence ts + go (DoneF rdm s ) = pure (Done rdm s) + go (FailF c fr ) = pure (Fail c fr) -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)