Commit e08d6021 authored by Andres Löh's avatar Andres Löh Committed by GitHub
Browse files

Merge pull request #3513 from kosmikus/count-conflicts-2

Count conflicts to speed up solver
parents d068a1cc 45c38b97
......@@ -239,6 +239,7 @@ instance Semigroup SavedConfig where
installDryRun = combine installDryRun,
installMaxBackjumps = combine installMaxBackjumps,
installReorderGoals = combine installReorderGoals,
installCountConflicts = combine installCountConflicts,
installIndependentGoals = combine installIndependentGoals,
installShadowPkgs = combine installShadowPkgs,
installStrongFlags = combine installStrongFlags,
......
......@@ -48,6 +48,7 @@ module Distribution.Client.Dependency (
addPreferences,
setPreferenceDefault,
setReorderGoals,
setCountConflicts,
setIndependentGoals,
setAvoidReinstalls,
setShadowPkgs,
......@@ -159,6 +160,7 @@ data DepResolverParams = DepResolverParams {
depResolverInstalledPkgIndex :: InstalledPackageIndex,
depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage,
depResolverReorderGoals :: ReorderGoals,
depResolverCountConflicts :: CountConflicts,
depResolverIndependentGoals :: IndependentGoals,
depResolverAvoidReinstalls :: AvoidReinstalls,
depResolverShadowPkgs :: ShadowPkgs,
......@@ -181,6 +183,7 @@ showDepResolverParams p =
(depResolverPreferences p)
++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
++ "\nreorder goals: " ++ show (depResolverReorderGoals p)
++ "\ncount conflicts: " ++ show (depResolverCountConflicts p)
++ "\nindependent goals: " ++ show (depResolverIndependentGoals p)
++ "\navoid reinstalls: " ++ show (depResolverAvoidReinstalls p)
++ "\nshadow packages: " ++ show (depResolverShadowPkgs p)
......@@ -234,6 +237,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
depResolverInstalledPkgIndex = installedPkgIndex,
depResolverSourcePkgIndex = sourcePkgIndex,
depResolverReorderGoals = ReorderGoals False,
depResolverCountConflicts = CountConflicts True,
depResolverIndependentGoals = IndependentGoals False,
depResolverAvoidReinstalls = AvoidReinstalls False,
depResolverShadowPkgs = ShadowPkgs False,
......@@ -279,6 +283,12 @@ setReorderGoals reorder params =
depResolverReorderGoals = reorder
}
setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts count params =
params {
depResolverCountConflicts = count
}
setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals indep params =
params {
......@@ -621,7 +631,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
Step (showDepResolverParams finalparams)
$ fmap (validateSolverResult platform comp indGoals)
$ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
$ runSolver solver (SolverConfig reordGoals cntConflicts
indGoals noReinstalls
shadowing strFlags maxBkjumps enableBj order)
platform comp installedPkgIndex sourcePkgIndex
pkgConfigDB preferences constraints targets
......@@ -632,7 +643,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
prefs defpref
installedPkgIndex
sourcePkgIndex
reorderGoals
reordGoals
cntConflicts
indGoals
noReinstalls
shadowing
......@@ -873,7 +885,7 @@ resolveWithoutDependencies :: DepResolverParams
-> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
resolveWithoutDependencies (DepResolverParams targets constraints
prefs defpref installedPkgIndex sourcePkgIndex
_reorderGoals _indGoals _avoidReinstalls
_reorderGoals _countConflicts _indGoals _avoidReinstalls
_shadowing _strFlags _maxBjumps _enableBj _order) =
collectEithers (map selectPackage targets)
where
......
......@@ -158,6 +158,8 @@ planPackages verbosity comp platform fetchFlags
. setReorderGoals reorderGoals
. setCountConflicts countConflicts
. setShadowPkgs shadowPkgs
. setStrongFlags strongFlags
......@@ -174,6 +176,7 @@ planPackages verbosity comp platform fetchFlags
logMsg message rest = debug verbosity message >> rest
reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
countConflicts = fromFlag (fetchCountConflicts fetchFlags)
independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
strongFlags = fromFlag (fetchStrongFlags fetchFlags)
......
......@@ -179,6 +179,8 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
. setReorderGoals reorderGoals
. setCountConflicts countConflicts
. setShadowPkgs shadowPkgs
. setStrongFlags strongFlags
......@@ -201,6 +203,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
countConflicts = fromFlag (freezeCountConflicts freezeFlags)
independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
strongFlags = fromFlag (freezeStrongFlags freezeFlags)
......
......@@ -379,6 +379,8 @@ planPackages comp platform mSandboxPkgInfo solver
. setReorderGoals reorderGoals
. setCountConflicts countConflicts
. setAvoidReinstalls avoidReinstalls
. setShadowPkgs shadowPkgs
......@@ -431,6 +433,7 @@ planPackages comp platform mSandboxPkgInfo solver
reinstall = fromFlag (installOverrideReinstall installFlags) ||
fromFlag (installReinstall installFlags)
reorderGoals = fromFlag (installReorderGoals installFlags)
countConflicts = fromFlag (installCountConflicts installFlags)
independentGoals = fromFlag (installIndependentGoals installFlags)
avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)
shadowPkgs = fromFlag (installShadowPkgs installFlags)
......
......@@ -196,6 +196,7 @@ resolveSolverSettings ProjectConfig{
n | n < 0 -> Nothing
| otherwise -> Just n
solverSettingReorderGoals = fromFlag projectConfigReorderGoals
solverSettingCountConflicts = fromFlag projectConfigCountConflicts
solverSettingStrongFlags = fromFlag projectConfigStrongFlags
--solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
--solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs
......@@ -211,6 +212,7 @@ resolveSolverSettings ProjectConfig{
projectConfigAllowNewer = Just AllowNewerNone,
projectConfigMaxBackjumps = Flag defaultMaxBackjumps,
projectConfigReorderGoals = Flag (ReorderGoals False),
projectConfigCountConflicts = Flag (CountConflicts True),
projectConfigStrongFlags = Flag (StrongFlags False)
--projectConfigIndependentGoals = Flag False,
--projectConfigShadowPkgs = Flag False,
......
......@@ -303,6 +303,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
installMaxBackjumps = projectConfigMaxBackjumps,
--installUpgradeDeps = projectConfigUpgradeDeps,
installReorderGoals = projectConfigReorderGoals,
installCountConflicts = projectConfigCountConflicts,
--installIndependentGoals = projectConfigIndependentGoals,
--installShadowPkgs = projectConfigShadowPkgs,
installStrongFlags = projectConfigStrongFlags
......@@ -495,6 +496,7 @@ convertToLegacySharedConfig
installMaxBackjumps = projectConfigMaxBackjumps,
installUpgradeDeps = mempty, --projectConfigUpgradeDeps,
installReorderGoals = projectConfigReorderGoals,
installCountConflicts = projectConfigCountConflicts,
installIndependentGoals = mempty, --projectConfigIndependentGoals,
installShadowPkgs = mempty, --projectConfigShadowPkgs,
installStrongFlags = projectConfigStrongFlags,
......@@ -827,7 +829,7 @@ legacySharedConfigFieldDescrs =
, "remote-build-reporting", "report-planning-failure"
, "one-shot", "jobs", "keep-going", "offline"
-- solver flags:
, "max-backjumps", "reorder-goals", "strong-flags"
, "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"
]
. commandOptionsToFields
) (installOptions ParseArgs)
......
......@@ -165,6 +165,7 @@ data ProjectConfigShared
projectConfigAllowNewer :: Maybe AllowNewer,
projectConfigMaxBackjumps :: Flag Int,
projectConfigReorderGoals :: Flag ReorderGoals,
projectConfigCountConflicts :: Flag CountConflicts,
projectConfigStrongFlags :: Flag StrongFlags
-- More things that only make sense for manual mode, not --local mode
......@@ -319,6 +320,7 @@ data SolverSettings
solverSettingAllowNewer :: AllowNewer,
solverSettingMaxBackjumps :: Maybe Int,
solverSettingReorderGoals :: ReorderGoals,
solverSettingCountConflicts :: CountConflicts,
solverSettingStrongFlags :: StrongFlags
-- Things that only make sense for manual mode, not --local mode
-- too much control!
......
......@@ -865,6 +865,8 @@ planPackages comp platform solver SolverSettings{..}
. setReorderGoals solverSettingReorderGoals
. setCountConflicts solverSettingCountConflicts
--TODO: [required eventually] should only be configurable for custom installs
-- . setAvoidReinstalls solverSettingAvoidReinstalls
......
......@@ -606,6 +606,7 @@ data FetchFlags = FetchFlags {
fetchSolver :: Flag PreSolver,
fetchMaxBackjumps :: Flag Int,
fetchReorderGoals :: Flag ReorderGoals,
fetchCountConflicts :: Flag CountConflicts,
fetchIndependentGoals :: Flag IndependentGoals,
fetchShadowPkgs :: Flag ShadowPkgs,
fetchStrongFlags :: Flag StrongFlags,
......@@ -620,6 +621,7 @@ defaultFetchFlags = FetchFlags {
fetchSolver = Flag defaultSolver,
fetchMaxBackjumps = Flag defaultMaxBackjumps,
fetchReorderGoals = Flag (ReorderGoals False),
fetchCountConflicts = Flag (CountConflicts True),
fetchIndependentGoals = Flag (IndependentGoals False),
fetchShadowPkgs = Flag (ShadowPkgs False),
fetchStrongFlags = Flag (StrongFlags False),
......@@ -666,6 +668,7 @@ fetchCommand = CommandUI {
optionSolverFlags showOrParseArgs
fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v })
fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v })
fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v })
fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v })
fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v })
......@@ -683,6 +686,7 @@ data FreezeFlags = FreezeFlags {
freezeSolver :: Flag PreSolver,
freezeMaxBackjumps :: Flag Int,
freezeReorderGoals :: Flag ReorderGoals,
freezeCountConflicts :: Flag CountConflicts,
freezeIndependentGoals :: Flag IndependentGoals,
freezeShadowPkgs :: Flag ShadowPkgs,
freezeStrongFlags :: Flag StrongFlags,
......@@ -697,6 +701,7 @@ defaultFreezeFlags = FreezeFlags {
freezeSolver = Flag defaultSolver,
freezeMaxBackjumps = Flag defaultMaxBackjumps,
freezeReorderGoals = Flag (ReorderGoals False),
freezeCountConflicts = Flag (CountConflicts True),
freezeIndependentGoals = Flag (IndependentGoals False),
freezeShadowPkgs = Flag (ShadowPkgs False),
freezeStrongFlags = Flag (StrongFlags False),
......@@ -742,6 +747,7 @@ freezeCommand = CommandUI {
optionSolverFlags showOrParseArgs
freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v })
freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v })
freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v })
freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v })
freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v })
......@@ -1144,6 +1150,7 @@ data InstallFlags = InstallFlags {
installDryRun :: Flag Bool,
installMaxBackjumps :: Flag Int,
installReorderGoals :: Flag ReorderGoals,
installCountConflicts :: Flag CountConflicts,
installIndependentGoals :: Flag IndependentGoals,
installShadowPkgs :: Flag ShadowPkgs,
installStrongFlags :: Flag StrongFlags,
......@@ -1176,6 +1183,7 @@ defaultInstallFlags = InstallFlags {
installDryRun = Flag False,
installMaxBackjumps = Flag defaultMaxBackjumps,
installReorderGoals = Flag (ReorderGoals False),
installCountConflicts = Flag (CountConflicts True),
installIndependentGoals= Flag (IndependentGoals False),
installShadowPkgs = Flag (ShadowPkgs False),
installStrongFlags = Flag (StrongFlags False),
......@@ -1321,6 +1329,7 @@ installOptions showOrParseArgs =
optionSolverFlags showOrParseArgs
installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v })
installReorderGoals (\v flags -> flags { installReorderGoals = v })
installCountConflicts (\v flags -> flags { installCountConflicts = v })
installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
installShadowPkgs (\v flags -> flags { installShadowPkgs = v })
installStrongFlags (\v flags -> flags { installStrongFlags = v }) ++
......@@ -2085,11 +2094,12 @@ optionSolver get set =
optionSolverFlags :: ShowOrParseArgs
-> (flags -> Flag Int ) -> (Flag Int -> flags -> flags)
-> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags)
-> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags)
-> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)
-> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags)
-> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags)
-> [OptionField flags]
optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl =
optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig getsip setsip getstrfl setstrfl =
[ option [] ["max-backjumps"]
("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
getmbj setmbj
......@@ -2100,6 +2110,11 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip
(fmap asBool . getrg)
(setrg . fmap ReorderGoals)
(yesNoOpt showOrParseArgs)
, option [] ["count-conflicts"]
"Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."
(fmap asBool . getcc)
(setcc . fmap CountConflicts)
(yesNoOpt showOrParseArgs)
-- TODO: Disabled for now because it does not work as advertised (yet).
{-
, option [] ["independent-goals"]
......
......@@ -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
......@@ -14,7 +15,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings (EnableBackjumping(..))
import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))
import qualified Distribution.Solver.Types.Progress as P
-- | This function takes the variable we're currently considering, an
......@@ -40,57 +41,99 @@ 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 -> Var QPN
-> ConflictSet QPN -> P.PSQ k (ConflictMap -> ConflictSetLog a)
-> ConflictMap -> ConflictSetLog a
backjump (EnableBackjumping enableBj) var initial xs =
F.foldr combine logBackjump xs initial
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)
-> (ConflictSet QPN -> ConflictMap -> ConflictSetLog a)
-> ConflictSet QPN -> ConflictMap -> ConflictSetLog a
combine x f csAcc cm =
let l = x cm
in case l of
P.Done d -> P.Done d
P.Fail (cs, cm')
| enableBj && not (var `CS.member` cs) -> logBackjump cs cm'
| otherwise -> f (csAcc `CS.union` cs) cm'
P.Step m ms ->
let l' = combine (\ _ -> ms) f csAcc cm
in P.Step m l'
logBackjump :: ConflictSet QPN -> ConflictSetLog a
logBackjump cs = failWith (Failure cs Backjump) cs
logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a
logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm)
type ConflictSetLog = P.Progress Message (ConflictSet QPN)
type ConflictSetLog = P.Progress Message (ConflictSet QPN, ConflictMap)
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)
)
getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a)
getFirstGoal ts =
P.casePSQ ts
(error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error
(\ k v _xs -> (k, v)) -- commit to the first goal choice
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))
exploreLog enableBj = cata go
exploreLog :: EnableBackjumping -> CountConflicts -> Tree QGoalReason
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
exploreLog enableBj (CountConflicts countConflicts) = 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) =
getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a)
getBestGoal'
| countConflicts = \ ts cm -> getBestGoal cm ts
| otherwise = \ ts _ -> getFirstGoal ts
go :: TreeF QGoalReason (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-> (Assignment -> ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
go (FailF c fr) _ = \ cm -> let failure = failWith (Failure c fr)
in if countConflicts
then failure (c, updateCM c cm)
else failure (c, cm)
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,
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
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
P.mapWithKey -- when descending ...
(\ i@(POption k _) r cm ->
let l = r (A (M.insert qpn k pa) fa sa) cm
in tryWith (TryP qpn i) l
)
ts
go (FChoiceF qfn gr _ _ ts) (A pa fa sa) =
backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- 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
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
P.mapWithKey -- when descending ...
(\ k r cm ->
let l = r (A pa (M.insert qfn k fa) sa) cm
in tryWith (TryF qfn k) l
)
ts
go (SChoiceF qsn gr _ ts) (A pa fa sa) =
backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- 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
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
P.mapWithKey -- when descending ...
(\ k r cm ->
let l = r (A pa fa (M.insert qsn k sa)) cm
in tryWith (TryS qsn k) l
)
ts
go (GoalChoiceF ts) a = \ cm ->
let (k, v) = getBestGoal' ts cm
l = v a cm
in continueWith (Next k) l
-- | Build a conflict set corresponding to the (virtual) option not to
-- choose a solution for a goal at all.
......@@ -121,9 +164,10 @@ avoidSet var gr =
-- | Interface.
backjumpAndExplore :: EnableBackjumping
-> CountConflicts
-> Tree QGoalReason -> Log Message (Assignment, RevDepMap)
backjumpAndExplore enableBj t =
toLog $ exploreLog enableBj t (A M.empty M.empty M.empty)
backjumpAndExplore enableBj countConflicts t =
toLog $ (exploreLog enableBj countConflicts 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
......@@ -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))]
......
......@@ -351,10 +351,18 @@ deferWeakFlagChoices = trav go
-- | 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.
-- 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).
-- Only approximates the number of choices in the branches
-- using dchoices which classifies every goal by the number
-- of active choices:
--
-- - 0 (guaranteed failure) or 1 (no other option) active choice
-- - 2 active choices
-- - 3 or more active choices
--
-- We pick the minimum goal according to this approximation.
-- In particular, if we encounter any goal in the first class
-- (0 or 1 option), we do not look any further and choose it
-- immediately.
--
-- Returns at most one choice.
--
......
......@@ -51,7 +51,8 @@ import Debug.Trace.Tree.Assoc (Assoc(..))
-- | Various options for the modular solver.
data SolverConfig = SolverConfig {
preferEasyGoalChoices :: ReorderGoals,
reorderGoals :: ReorderGoals,
countConflicts :: CountConflicts,
independentGoals :: IndependentGoals,
avoidReinstalls :: AvoidReinstalls,
shadowPkgs :: ShadowPkgs,
......@@ -103,15 +104,12 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
prunePhase $
buildPhase
where
explorePhase = backjumpAndExplore (enableBackjumping sc)
explorePhase = backjumpAndExplore (enableBackjumping sc) (countConflicts sc)
detectCycles = traceTree "cycles.json" id . detectCyclesPhase
heuristicsPhase =
let heuristicsTree = traceTree "heuristics.json" id
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)
Nothing -> goalChoiceHeuristics .
heuristicsTree .
P.deferWeakFlagChoices .
P.deferSetupChoices .
......@@ -138,6 +136,34 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
$ addLinking
$ buildTree idx (independentGoals sc) userGoals
-- Counting conflicts and reordering goals interferes, as both are strategies to
-- change the order of goals.
--
-- We therefore change the strategy based on whether --count-conflicts is set or
-- not:
--
-- - when --count-conflicts is set, we use preferReallyEasyGoalChoices, which
-- prefers (keeps) goals only if the have 0 or 1 enabled choice.
--
-- - when --count-conflicts is not set, we use preferEasyGoalChoices, which
-- (next to preferring goals with 0 or 1 enabled choice)
-- also prefers goals that have 2 enabled choices over goals with more than
-- two enabled choices.
--
-- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes
-- to just a single option. This was a way to work around a space leak that was
-- unnecessary and is now fixed, so we no longer do it.
--
-- If --count-conflicts is active, it will then choose among the remaining goals
-- the one that has been responsible for the most conflicts so far.
--
-- Otherwise, we simply choose the first remaining goal.
--
goalChoiceHeuristics
| asBool (reorderGoals sc) && asBool (countConflicts sc) = P.preferReallyEasyGoalChoices
| asBool (reorderGoals sc) = P.preferEasyGoalChoices
| otherwise = id {- P.firstGoal -}
-- | Dump solver tree to a file (in debugging mode)
--
-- This only does something if the @debug-tracetree@ configure argument was
......
......@@ -7,6 +7,7 @@ module Distribution.Solver.Types.Settings
, ShadowPkgs(..)
, StrongFlags(..)
, EnableBackjumping(..)
, CountConflicts(..)
) where
import Distribution.Simple.Setup ( BooleanFlag(..) )
......@@ -16,6 +17,9 @@ import GHC.Generics (Generic)
newtype ReorderGoals = ReorderGoals Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype CountConflicts = CountConflicts Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype IndependentGoals = IndependentGoals Bool
deriving (BooleanFlag, Eq, Generic, Show)
......@@ -32,6 +36,7 @@ newtype EnableBackjumping = EnableBackjumping Bool
deriving (BooleanFlag, Eq, Generic, Show)
instance Binary ReorderGoals
instance Binary CountConflicts
instance Binary IndependentGoals