Improve goal reorder heuristics.

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
 

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,55 +292,69 @@ 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
 -- flags that are explicitly declared to be weak in the index.
 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

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

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