Count conflicts and prefer goals that contribute to conflicts.

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

@@ -4,6 +4,7 @@ module Distribution.Solver.Modular.Explore
     ) where
 
 import Data.Foldable as F
+import Data.List as L (foldl')
 import Data.Map as M
 
 import Distribution.Solver.Modular.Assignment
@@ -16,6 +17,7 @@ import Distribution.Solver.Modular.Tree
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings (EnableBackjumping(..))
 import qualified Distribution.Solver.Types.Progress as P
+import Distribution.Solver.Modular.Var
 
 -- | This function takes the variable we're currently considering, an
 -- initial conflict set and a
@@ -40,57 +42,85 @@ import qualified Distribution.Solver.Types.Progress as P
 -- with the (virtual) option not to choose anything for the current
 -- variable. See also the comments for 'avoidSet'.
 --
-backjump :: F.Foldable t => EnableBackjumping -> Var QPN
-         -> ConflictSet QPN -> t (ConflictSetLog a) -> ConflictSetLog a
-backjump (EnableBackjumping enableBj) var initial xs =
-    F.foldr combine logBackjump xs initial
+backjump :: EnableBackjumping -> Var QPN
+         -> ConflictSet QPN -> ConflictMap -> P.PSQ k (ConflictMap -> (ConflictSetLog a, ConflictMap))
+         -> (ConflictSetLog a, ConflictMap)
+backjump (EnableBackjumping enableBj) var initial cm xs =
+    F.foldr combine logBackjump xs initial cm
   where
-    combine :: ConflictSetLog a
-            -> (ConflictSet QPN -> ConflictSetLog a)
-            ->  ConflictSet QPN -> ConflictSetLog a
-    combine (P.Done x)    _ _               = P.Done x
-    combine (P.Fail cs)   f csAcc
-      | enableBj && not (var `CS.member` cs) = logBackjump cs
-      | otherwise                = f (csAcc `CS.union` cs)
-    combine (P.Step m ms) f cs   = P.Step m (combine ms f cs)
+    combine :: (ConflictMap -> (ConflictSetLog a, ConflictMap))
+            -> (ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap))
+            ->  ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap)
+    combine x f csAcc cm =
+      let (l, cm') = x cm
+      in case l of
+           P.Done x  -> (P.Done x, cm')
+           P.Fail cs
+             | enableBj && not (var `CS.member` cs) -> logBackjump cs cm'
+             | otherwise                            -> f (csAcc `CS.union` cs) cm'
+           P.Step m ms ->
+             let (l', cm'') = combine (\ x -> (ms, x)) f csAcc cm'
+             in  (P.Step m l', cm'')
 
-    logBackjump :: ConflictSet QPN -> ConflictSetLog a
-    logBackjump cs = failWith (Failure cs Backjump) cs
+    logBackjump :: ConflictSet QPN -> ConflictMap -> (ConflictSetLog a, ConflictMap)
+    logBackjump cs cm' = (failWith (Failure cs Backjump) cs, cm')
 
 type ConflictSetLog = P.Progress Message (ConflictSet QPN)
 
+type ConflictMap = Map (Var QPN) Int
+
+getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a)
+getBestGoal cm =
+  P.maximumBy
+    ( flip (M.findWithDefault 0) cm
+    . (\ (Goal v _) -> v)
+    )
+
+updateCM :: ConflictSet QPN -> ConflictMap -> ConflictMap
+updateCM cs cm =
+  L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs)
+  where
+    inc Nothing  = Just 1
+    inc (Just n) = Just $! n + 1
+
 -- | A tree traversal that simultaneously propagates conflict sets up
 -- the tree from the leaves and creates a log.
 exploreLog :: EnableBackjumping -> Tree QGoalReason
-           -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
+           -> (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
 exploreLog enableBj = cata go
   where
-    go :: TreeF QGoalReason (Assignment -> ConflictSetLog (Assignment, RevDepMap))
-                         -> (Assignment -> ConflictSetLog (Assignment, RevDepMap))
-    go (FailF c fr)          _           = failWith (Failure c fr) c
-    go (DoneF rdm)           a           = succeedWith Success (a, rdm)
-    go (PChoiceF qpn gr     ts) (A pa fa sa)   =
-      backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,
+    go :: TreeF QGoalReason (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
+                         -> (Assignment -> ConflictMap -> (ConflictSetLog (Assignment, RevDepMap), ConflictMap))
+    go (FailF c fr)          _  cm       = (failWith (Failure c fr) c, updateCM c cm)
+    go (DoneF rdm)           a  cm       = (succeedWith Success (a, rdm), cm)
+    go (PChoiceF qpn gr     ts) (A pa fa sa) cm  =
+      backjump enableBj (P qpn) (avoidSet (P qpn) gr) cm $ -- try children in order,
       P.mapWithKey                                -- when descending ...
-        (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ...
-                    r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice
+        (\ i@(POption k _) r cm ->
+          let (l, cm') = r (A (M.insert qpn k pa) fa sa) cm
+          in  (tryWith (TryP qpn i) l, cm')
+        )
       ts
-    go (FChoiceF qfn gr _ _ ts) (A pa fa sa)   =
-      backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,
+    go (FChoiceF qfn gr _ _ ts) (A pa fa sa) cm  =
+      backjump enableBj (F qfn) (avoidSet (F qfn) gr) cm $ -- try children in order,
       P.mapWithKey                                -- when descending ...
-        (\ k r -> tryWith (TryF qfn k) $          -- log and ...
-                    r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice
+        (\ k r cm ->
+          let (l, cm') = r (A pa (M.insert qfn k fa) sa) cm
+          in  (tryWith (TryF qfn k) l, cm')
+        )
       ts
-    go (SChoiceF qsn gr _   ts) (A pa fa sa)   =
-      backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,
+    go (SChoiceF qsn gr _   ts) (A pa fa sa) cm  =
+      backjump enableBj (S qsn) (avoidSet (S qsn) gr) cm $ -- try children in order,
       P.mapWithKey                                -- when descending ...
-        (\ k r -> tryWith (TryS qsn k) $          -- log and ...
-                    r (A pa fa (M.insert qsn k sa))) -- record the pkg choice
+        (\ k r cm ->
+          let (l, cm') = r (A pa fa (M.insert qsn k sa)) cm
+          in  (tryWith (TryS qsn k) l, cm')
+        )
       ts
-    go (GoalChoiceF        ts) a           =
-      P.casePSQ ts
-        (failWith (Failure CS.empty EmptyGoalChoice) CS.empty) -- empty goal choice is an internal error
-        (\ k v _xs -> continueWith (Next k) (v a))             -- commit to the first goal choice
+    go (GoalChoiceF        ts) a cm          =
+      let (k, v) = getBestGoal cm ts
+          (l, cm') = v a cm
+      in (continueWith (Next k) l, cm')
 
 -- | Build a conflict set corresponding to the (virtual) option not to
 -- choose a solution for a goal at all.
@@ -123,7 +153,7 @@ avoidSet var gr =
 backjumpAndExplore :: EnableBackjumping
                    -> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
 backjumpAndExplore enableBj t =
-    toLog $ exploreLog enableBj t (A M.empty M.empty M.empty)
+    toLog $ fst $ exploreLog enableBj t (A M.empty M.empty M.empty) M.empty
   where
     toLog :: P.Progress step fail done -> Log step done
     toLog = P.foldProgress P.Step (const (P.Fail ())) P.Done

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

@@ -19,6 +19,7 @@ module Distribution.Solver.Modular.PSQ
     , mapKeys
     , mapWithKey
     , mapWithKeyState
+    , maximumBy
     , minimumBy
     , null
     , prefer
@@ -124,6 +125,10 @@ dminimumBy sel (PSQ (x : xs)) = go (sel (snd x)) x xs
       where
         d = sel (snd y)
 
+maximumBy :: (k -> Int) -> PSQ k a -> (k, a)
+maximumBy sel (PSQ xs) =
+  S.minimumBy (flip (comparing (sel . fst))) xs
+
 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))]

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

@@ -110,8 +110,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
       in case goalOrder sc of
            Nothing -> (if asBool (preferEasyGoalChoices sc)
                         then P.preferEasyGoalChoices -- also leaves just one choice
-                        else P.firstGoal) . -- after doing goal-choice heuristics,
-                                            -- commit to the first choice (saves space)
+                        else id) . 
                       heuristicsTree .
                       P.deferWeakFlagChoices .
                       P.deferSetupChoices .