diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 56b07440b55..3227dc264f8 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -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, diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 516eca86678..d68a757a185 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Fetch.hs b/cabal-install/Distribution/Client/Fetch.hs index 433867ed8b4..9e4420392c9 100644 --- a/cabal-install/Distribution/Client/Fetch.hs +++ b/cabal-install/Distribution/Client/Fetch.hs @@ -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) diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 95d1b88c526..6ae45446284 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -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) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 6c6f7f4f035..db4488dc4fc 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -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) diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index a6e84a28070..9277ef3b6df 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -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, diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index d481ddee6b4..051bc262ad3 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -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) diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index 48abba4a39b..cea10815988 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -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! diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index d08b467cf51..004080a0399 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 0dd15bef902..b804683216d 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -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"] diff --git a/cabal-install/Distribution/Solver/Modular/Explore.hs b/cabal-install/Distribution/Solver/Modular/Explore.hs index a24725bb5e9..775177f976b 100644 --- a/cabal-install/Distribution/Solver/Modular/Explore.hs +++ b/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 @@ -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 diff --git a/cabal-install/Distribution/Solver/Modular/PSQ.hs b/cabal-install/Distribution/Solver/Modular/PSQ.hs index b4e8f244cf8..f4e6d4ea117 100644 --- a/cabal-install/Distribution/Solver/Modular/PSQ.hs +++ b/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))] diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index 68158e81024..cfa2d1a28e1 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -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. -- diff --git a/cabal-install/Distribution/Solver/Modular/Solver.hs b/cabal-install/Distribution/Solver/Modular/Solver.hs index 64826f4412a..4cab88686c0 100644 --- a/cabal-install/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/Distribution/Solver/Modular/Solver.hs @@ -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 diff --git a/cabal-install/Distribution/Solver/Types/Settings.hs b/cabal-install/Distribution/Solver/Types/Settings.hs index 6207af15759..30603d87421 100644 --- a/cabal-install/Distribution/Solver/Types/Settings.hs +++ b/cabal-install/Distribution/Solver/Types/Settings.hs @@ -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 instance Binary AvoidReinstalls instance Binary ShadowPkgs diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index b5b40ceed4b..4ecf80fc1b5 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -344,6 +344,7 @@ instance Arbitrary ProjectConfigShared where <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = @@ -352,18 +353,18 @@ instance Arbitrary ProjectConfigShared where shrink (ProjectConfigShared x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 - x10 x11 x12 x13) = + x10 x11 x12 x13 x14) = [ ProjectConfigShared x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04' x05' (postShrink_Constraints x06') x07' x08' x09' - x10' x11' x12' x13' + x10' x11' x12' x13' x14' | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), - (x10', x11', x12', x13')) + (x10', x11', x12', x13', x14')) <- shrink ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04), (x05, preShrink_Constraints x06, x07, x08, x09), - (x10, x11, x12, x13)) + (x10, x11, x12, x13, x14)) ] where preShrink_Constraints = map fst @@ -579,6 +580,9 @@ instance Arbitrary PreSolver where instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary +instance Arbitrary CountConflicts where + arbitrary = CountConflicts <$> arbitrary + instance Arbitrary StrongFlags where arbitrary = StrongFlags <$> arbitrary