From 150d6ca9b706498659b0c905dcd8ff661ee466e3 Mon Sep 17 00:00:00 2001
From: Andres Loeh <andres@well-typed.com>
Date: Thu, 3 Mar 2016 21:05:03 +0100
Subject: [PATCH] Improve goal reorder heuristics.
This change primarily does two things:
1. For `--reorder-goals`, we use a dedicated datatype `Degree`
rather than an `Int` to compute the approximate branching
degree. We map 0 and 1 to the same value. We then use a
lazy ordering and a shortcutting minimum function to look
for the "best" goal.
The motivation here is that we do not want to spend
unnecessary work. Following any goal that has 0 or 1 as degree
cannot really be "wrong", so we should not look at any others
and waste time.
This will still not always make the use of `--reorder-goals`
better than not using it, but it will reduce the overhead
introduced by it.
2. We use partitioning rather than sorting for most of the other
goal reordering heuristics that are active in all situations.
I think this is slightly more straightforward and also slightly
more efficient, whether `--reorder-goals` is used or not.
I have run some preliminary performance comparisons and they
seem to confirm that in both cases separately (with or without
`--reorder-goals`), these changes are a relative improvement
over the status quo. I will run additional tests before
merging this into master.
---
.../Client/Dependency/Modular/PSQ.hs | 107 ++++++++++++++++--
.../Client/Dependency/Modular/Preference.hs | 76 +++++++------
.../Client/Dependency/Modular/Solver.hs | 9 +-
.../Client/Dependency/Modular/Tree.hs | 29 +++--
4 files changed, 166 insertions(+), 55 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
index c71df05603..417832e7ad 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs
@@ -1,21 +1,29 @@
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Distribution.Client.Dependency.Modular.PSQ
( PSQ(..) -- Unit test needs constructor access
+ , Degree(..)
, casePSQ
, cons
+ , degree
, delete
+ , dminimumBy
, length
- , llength
, lookup
, filter
, filterKeys
+ , firstOnly
, fromList
+ , isZeroOrOne
, keys
, map
, mapKeys
, mapWithKey
, mapWithKeyState
+ , minimumBy
, null
+ , prefer
+ , preferByKeys
+ , preferOrElse
, snoc
, sortBy
, sortByKeys
@@ -36,6 +44,7 @@ import Control.Arrow (first, second)
import qualified Data.Foldable as F
import Data.Function
import qualified Data.List as S
+import Data.Ord (comparing)
import Data.Traversable
import Prelude hiding (foldr, length, lookup, filter, null, map)
@@ -94,6 +103,62 @@ sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)
sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a
sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs)
+-- | Given a measure in form of a pseudo-peano-natural number,
+-- determine the approximate minimum. This is designed to stop
+-- even traversing the list as soon as we find any element with
+-- measure 'ZeroOrOne'.
+--
+-- Always returns a one-element queue (except if the queue is
+-- empty, then we return an empty queue again).
+--
+dminimumBy :: (a -> Degree) -> PSQ k a -> PSQ k a
+dminimumBy _ (PSQ []) = PSQ []
+dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs
+ where
+ go ZeroOrOne v _ = PSQ [v]
+ go _ v [] = PSQ [v]
+ go c v (y : ys) = case compare c d of
+ LT -> go c v ys
+ EQ -> go c v ys
+ GT -> go d y ys
+ where
+ d = sel (snd y)
+
+minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a
+minimumBy sel (PSQ xs) =
+ PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))]
+
+-- | Will partition the list according to the predicate. If
+-- there is any element that satisfies the precidate, then only
+-- the elements satisfying the predicate are returned.
+-- Otherwise, the rest is returned.
+--
+prefer :: (a -> Bool) -> PSQ k a -> PSQ k a
+prefer p (PSQ xs) =
+ let
+ (pro, con) = S.partition (p . snd) xs
+ in
+ if S.null pro then PSQ con else PSQ pro
+
+-- | Variant of 'prefer' that takes a continuation for the case
+-- that there are none of the desired elements.
+preferOrElse :: (a -> Bool) -> (PSQ k a -> PSQ k a) -> PSQ k a -> PSQ k a
+preferOrElse p k (PSQ xs) =
+ let
+ (pro, con) = S.partition (p . snd) xs
+ in
+ if S.null pro then k (PSQ con) else PSQ pro
+
+-- | Variant of 'prefer' that takes a predicate on the keys
+-- rather than on the values.
+--
+preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a
+preferByKeys p (PSQ xs) =
+ let
+ (pro, con) = S.partition (p . fst) xs
+ in
+ if S.null pro then PSQ con else PSQ pro
+
filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a
filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs)
@@ -103,18 +168,44 @@ filter p (PSQ xs) = PSQ (S.filter (p . snd) xs)
length :: PSQ k a -> Int
length (PSQ xs) = S.length xs
--- | "Lazy length".
+-- | Approximation of the branching degree.
+--
+-- This is designed for computing the branching degree of a goal choice
+-- node. If the degree is 0 or 1, it is always good to take that goal,
+-- because we can either abort immediately, or have no other choice anyway.
+--
+-- So we do not actually want to compute the full degree (which is
+-- somewhat costly) in cases where we have such an easy choice.
--
--- Only approximates the length, but doesn't force the list.
-llength :: PSQ k a -> Int
-llength (PSQ []) = 0
-llength (PSQ [_]) = 1
-llength (PSQ [_, _]) = 2
-llength (PSQ _) = 3
+data Degree = ZeroOrOne | Two | Other
+ deriving (Show, Eq)
+
+instance Ord Degree where
+ compare ZeroOrOne _ = LT -- lazy approximation
+ compare _ ZeroOrOne = GT -- approximation
+ compare Two Two = EQ
+ compare Two Other = LT
+ compare Other Two = GT
+ compare Other Other = EQ
+
+degree :: PSQ k a -> Degree
+degree (PSQ []) = ZeroOrOne
+degree (PSQ [_]) = ZeroOrOne
+degree (PSQ [_, _]) = Two
+degree (PSQ _) = Other
null :: PSQ k a -> Bool
null (PSQ xs) = S.null xs
+isZeroOrOne :: PSQ k a -> Bool
+isZeroOrOne (PSQ []) = True
+isZeroOrOne (PSQ [_]) = True
+isZeroOrOne _ = False
+
+firstOnly :: PSQ k a -> PSQ k a
+firstOnly (PSQ []) = PSQ []
+firstOnly (PSQ (x : _)) = PSQ [x]
+
toList :: PSQ k a -> [(k, a)]
toList (PSQ xs) = xs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 463b46cd1e..63dfbec1f4 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -7,10 +7,11 @@ module Distribution.Client.Dependency.Modular.Preference
, enforcePackageConstraints
, enforceSingleInstanceRestriction
, firstGoal
- , lpreferEasyGoalChoices
, preferBaseGoalChoice
+ , preferEasyGoalChoices
, preferLinked
, preferPackagePreferences
+ , preferReallyEasyGoalChoices
, requireInstalled
) where
@@ -25,7 +26,6 @@ import Control.Applicative
import qualified Data.Set as S
import Prelude hiding (sequence)
import Control.Monad.Reader hiding (sequence)
-import Data.Ord
import Data.Map (Map)
import Data.Traversable (sequence)
@@ -69,7 +69,6 @@ preferLinked = trav go
cmpL (Just _) Nothing = LT
cmpL (Just _) (Just _) = EQ
-
-- | Ordering that treats versions satisfying more preferred ranges as greater
-- than versions satisfying less preferred ranges.
preferredVersionsOrdering :: [VR] -> Ver -> Ver -> Ordering
@@ -283,8 +282,7 @@ avoidReinstalls p = trav go
firstGoal :: Tree a -> Tree a
firstGoal = trav go
where
- go (GoalChoiceF xs) = -- P.casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info
- P.casePSQ xs (GoalChoiceF (P.fromList [])) (\ g t _ -> GoalChoiceF (P.fromList [(g, t)]))
+ go (GoalChoiceF xs) = GoalChoiceF (P.firstOnly xs)
go x = x
-- Note that we keep empty choice nodes, because they mean success.
@@ -294,26 +292,24 @@ firstGoal = trav go
preferBaseGoalChoice :: Tree a -> Tree a
preferBaseGoalChoice = trav go
where
- go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)
+ go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys isBase xs)
go x = x
- preferBase :: OpenGoal comp -> OpenGoal comp -> Ordering
- preferBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) _ | unPN pn == "base" = LT
- preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT
- preferBase _ _ = EQ
+ isBase :: OpenGoal comp -> Bool
+ isBase (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = True
+ isBase _ = False
-- | Deal with setup dependencies after regular dependencies, so that we can
-- will link setup depencencies against package dependencies when possible
deferSetupChoices :: Tree a -> Tree a
deferSetupChoices = trav go
where
- go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys deferSetup xs)
+ go (GoalChoiceF xs) = GoalChoiceF (P.preferByKeys noSetup xs)
go x = x
- deferSetup :: OpenGoal comp -> OpenGoal comp -> Ordering
- deferSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) _ = GT
- deferSetup _ (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = LT
- deferSetup _ _ = EQ
+ noSetup :: OpenGoal comp -> Bool
+ noSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = False
+ noSetup _ = True
-- | Transformation that tries to avoid making weak flag choices early.
-- Weak flags are trivial flags (not influencing dependencies) or such
@@ -321,28 +317,44 @@ deferSetupChoices = trav go
deferWeakFlagChoices :: Tree a -> Tree a
deferWeakFlagChoices = trav go
where
- go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)
+ go (GoalChoiceF xs) = GoalChoiceF (P.prefer noWeakStanza (P.prefer noWeakFlag xs))
go x = x
- -- weak flags go very last, weak stanzas second last
- defer :: Tree a -> Tree a -> Ordering
- defer (FChoice _ _ True _ _) _ = GT
- defer _ (FChoice _ _ True _ _) = LT
- defer (SChoice _ _ True _) _ = GT
- defer _ (SChoice _ _ True _) = LT
- defer _ _ = EQ
-
--- Transformation that sorts choice nodes so that
--- child nodes with a small branching degree are preferred. As a
--- special case, choices with 0 branches will be preferred (as they
--- are immediately considered inconsistent), and choices with 1
--- branch will also be preferred (as they don't involve choice).
+ noWeakStanza :: Tree a -> Bool
+ noWeakStanza (SChoice _ _ True _) = False
+ noWeakStanza _ = True
+
+ noWeakFlag :: Tree a -> Bool
+ noWeakFlag (FChoice _ _ True _ _) = False
+ noWeakFlag _ = True
+
+-- | Transformation that sorts choice nodes so that
+-- child nodes with a small branching degree are preferred.
--
-- Only approximates the number of choices in the branches.
-lpreferEasyGoalChoices :: Tree a -> Tree a
-lpreferEasyGoalChoices = trav go
+-- In particular, we try to take any goal immediately if it has
+-- a branching degree of 0 (guaranteed failure) or 1 (no other
+-- choice possible).
+--
+-- Returns at most one choice.
+--
+preferEasyGoalChoices :: Tree a -> Tree a
+preferEasyGoalChoices = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.dminimumBy dchoices xs)
+ -- (a different implementation that seems slower):
+ -- GoalChoiceF (P.firstOnly (P.preferOrElse zeroOrOneChoices (P.minimumBy choices) xs))
+ go x = x
+
+-- | A variant of 'preferEasyGoalChoices' that just keeps the
+-- ones with a branching degree of 0 or 1. Note that unlike
+-- 'preferEasyGoalChoices', this may return more than one
+-- choice.
+--
+preferReallyEasyGoalChoices :: Tree a -> Tree a
+preferReallyEasyGoalChoices = trav go
where
- go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs)
+ go (GoalChoiceF xs) = GoalChoiceF (P.prefer zeroOrOneChoices xs)
go x = x
-- | Monad used internally in enforceSingleInstanceRestriction
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index 5fd69aa22d..fd8ea348a2 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -74,13 +74,12 @@ solve sc cinfo idx userPrefs userConstraints userGoals =
buildPhase
where
explorePhase = exploreTreeLog . backjump
- heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
- P.deferSetupChoices .
+ heuristicsPhase = (if preferEasyGoalChoices sc
+ then P.preferEasyGoalChoices -- also leaves just one choice
+ else P.firstGoal) .
P.deferWeakFlagChoices .
+ P.deferSetupChoices .
P.preferBaseGoalChoice .
- (if preferEasyGoalChoices sc
- then P.lpreferEasyGoalChoices
- else id) .
P.preferLinked
preferencesPhase = P.preferPackagePreferences userPrefs
validationPhase = P.enforceManualFlags . -- can only be done after user constraints
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index 42d403ef94..d170b565cc 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -7,11 +7,12 @@ module Distribution.Client.Dependency.Modular.Tree
, ana
, cata
, choices
+ , dchoices
, inn
, innM
- , lchoices
, para
, trav
+ , zeroOrOneChoices
) where
import Control.Monad hiding (mapM, sequence)
@@ -134,15 +135,23 @@ choices (GoalChoice _ ) = 1
choices (Done _ ) = 1
choices (Fail _ _ ) = 0
--- | Variant of 'choices' that only approximates the number of choices,
--- using 'llength'.
-lchoices :: Tree a -> Int
-lchoices (PChoice _ _ ts) = P.llength (P.filter active ts)
-lchoices (FChoice _ _ _ _ ts) = P.llength (P.filter active ts)
-lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts)
-lchoices (GoalChoice _ ) = 1
-lchoices (Done _ ) = 1
-lchoices (Fail _ _ ) = 0
+-- | Variant of 'choices' that only approximates the number of choices.
+dchoices :: Tree a -> P.Degree
+dchoices (PChoice _ _ ts) = P.degree (P.filter active ts)
+dchoices (FChoice _ _ _ _ ts) = P.degree (P.filter active ts)
+dchoices (SChoice _ _ _ ts) = P.degree (P.filter active ts)
+dchoices (GoalChoice _ ) = P.ZeroOrOne
+dchoices (Done _ ) = P.ZeroOrOne
+dchoices (Fail _ _ ) = P.ZeroOrOne
+
+-- | Variant of 'choices' that only approximates the number of choices.
+zeroOrOneChoices :: Tree a -> Bool
+zeroOrOneChoices (PChoice _ _ ts) = P.isZeroOrOne (P.filter active ts)
+zeroOrOneChoices (FChoice _ _ _ _ ts) = P.isZeroOrOne (P.filter active ts)
+zeroOrOneChoices (SChoice _ _ _ ts) = P.isZeroOrOne (P.filter active ts)
+zeroOrOneChoices (GoalChoice _ ) = True
+zeroOrOneChoices (Done _ ) = True
+zeroOrOneChoices (Fail _ _ ) = True
-- | Catamorphism on trees.
cata :: (TreeF a b -> b) -> Tree a -> b
--
GitLab