Skip to content

Commit

Permalink
Merge branch 'master' into add-bootstrap-postjob
Browse files Browse the repository at this point in the history
  • Loading branch information
BinderDavid authored Nov 19, 2023
2 parents 36a32f4 + c97092f commit ecc5aa2
Show file tree
Hide file tree
Showing 7 changed files with 11 additions and 115 deletions.
1 change: 0 additions & 1 deletion bootstrap/linux-8.10.7.json
Original file line number Diff line number Diff line change
Expand Up @@ -337,7 +337,6 @@
"cabal_sha256": null,
"component": "lib:cabal-install-solver",
"flags": [
"-debug-conflict-sets",
"-debug-expensive-assertions",
"-debug-tracetree"
],
Expand Down
1 change: 0 additions & 1 deletion bootstrap/linux-9.0.2.json
Original file line number Diff line number Diff line change
Expand Up @@ -337,7 +337,6 @@
"cabal_sha256": null,
"component": "lib:cabal-install-solver",
"flags": [
"-debug-conflict-sets",
"-debug-expensive-assertions",
"-debug-tracetree"
],
Expand Down
1 change: 0 additions & 1 deletion bootstrap/linux-9.2.7.json
Original file line number Diff line number Diff line change
Expand Up @@ -300,7 +300,6 @@
"cabal_sha256": null,
"component": "lib:cabal-install-solver",
"flags": [
"-debug-conflict-sets",
"-debug-expensive-assertions",
"-debug-tracetree"
],
Expand Down
1 change: 0 additions & 1 deletion bootstrap/linux-9.4.4.json
Original file line number Diff line number Diff line change
Expand Up @@ -290,7 +290,6 @@
"cabal_sha256": null,
"component": "lib:cabal-install-solver",
"flags": [
"-debug-conflict-sets",
"-debug-expensive-assertions",
"-debug-tracetree"
],
Expand Down
9 changes: 0 additions & 9 deletions cabal-install-solver/cabal-install-solver.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -27,11 +27,6 @@ flag debug-expensive-assertions
default: False
manual: True

flag debug-conflict-sets
description: Add additional information to ConflictSets
default: False
manual: True

flag debug-tracetree
description: Compile in support for tracetree (used to debug the solver)
default: False
Expand Down Expand Up @@ -119,10 +114,6 @@ library
if flag(debug-expensive-assertions)
cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS

if flag(debug-conflict-sets)
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >=4.9

if flag(debug-tracetree)
cpp-options: -DDEBUG_TRACETREE
build-depends: tracetree ^>=0.1
Expand Down
99 changes: 10 additions & 89 deletions cabal-install-solver/src/Distribution/Solver/Modular/ConflictSet.hs
Original file line number Diff line number Diff line change
@@ -1,7 +1,3 @@
{-# LANGUAGE CPP #-}
#ifdef DEBUG_CONFLICT_SETS
{-# LANGUAGE ImplicitParams #-}
#endif
-- | Conflict sets
--
-- Intended for double import
Expand All @@ -13,9 +9,6 @@ module Distribution.Solver.Modular.ConflictSet (
, Conflict(..)
, ConflictMap
, OrderedVersionRange(..)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin
#endif
, showConflictSet
, showCSSortedByFrequency
, showCSWithFrequency
Expand Down Expand Up @@ -44,36 +37,17 @@ import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.Set as S

#ifdef DEBUG_CONFLICT_SETS
import Data.Tree
import GHC.Stack
#endif

import Distribution.Solver.Modular.Var
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.PackagePath

-- | The set of variables involved in a solver conflict, each paired with
-- details about the conflict.
data ConflictSet = CS {
newtype ConflictSet = CS {
-- | The set of variables involved in the conflict
conflictSetToMap :: !(Map (Var QPN) (Set Conflict))

#ifdef DEBUG_CONFLICT_SETS
-- | The origin of the conflict set
--
-- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,
-- we record the origin of every conflict set. For new conflict sets
-- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations
-- that construct new conflict sets from existing conflict sets ('union',
-- 'filter', ..) we record the 'CallStack' to the call to the combinator
-- as well as the 'CallStack's of the input conflict sets.
--
-- Requires @GHC >= 7.10@.
, conflictSetOrigin :: Tree CallStack
#endif
conflictSetToMap :: Map (Var QPN) (Set Conflict)
}
deriving (Show)
deriving (Eq, Show)

-- | More detailed information about how a conflict set variable caused a
-- conflict. This information can be used to determine whether a second value
Expand Down Expand Up @@ -112,12 +86,6 @@ newtype OrderedVersionRange = OrderedVersionRange VR
instance Ord OrderedVersionRange where
compare = compare `on` show

instance Eq ConflictSet where
(==) = (==) `on` conflictSetToMap

instance Ord ConflictSet where
compare = compare `on` conflictSetToMap

showConflictSet :: ConflictSet -> String
showConflictSet = intercalate ", " . map showVar . toList

Expand Down Expand Up @@ -147,76 +115,37 @@ toSet = M.keysSet . conflictSetToMap
toList :: ConflictSet -> [Var QPN]
toList = M.keys . conflictSetToMap

union ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
ConflictSet -> ConflictSet -> ConflictSet
union :: ConflictSet -> ConflictSet -> ConflictSet
union cs cs' = CS {
conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs')
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])
#endif
}

unions ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
[ConflictSet] -> ConflictSet
unions :: [ConflictSet] -> ConflictSet
unions css = CS {
conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc (map conflictSetOrigin css)
#endif
}

insert ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Var QPN -> ConflictSet -> ConflictSet
insert :: Var QPN -> ConflictSet -> ConflictSet
insert var cs = CS {
conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc [conflictSetOrigin cs]
#endif
}

delete :: Var QPN -> ConflictSet -> ConflictSet
delete var cs = CS {
conflictSetToMap = M.delete var (conflictSetToMap cs)
}

empty ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
ConflictSet
empty :: ConflictSet
empty = CS {
conflictSetToMap = M.empty
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}

singleton ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Var QPN -> ConflictSet
singleton :: Var QPN -> ConflictSet
singleton var = singletonWithConflict var OtherConflict

singletonWithConflict ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Var QPN -> Conflict -> ConflictSet
singletonWithConflict :: Var QPN -> Conflict -> ConflictSet
singletonWithConflict var conflict = CS {
conflictSetToMap = M.singleton var (S.singleton conflict)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}

size :: ConflictSet -> Int
Expand All @@ -228,17 +157,9 @@ member var = M.member var . conflictSetToMap
lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict)
lookup var = M.lookup var . conflictSetToMap

fromList ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
[Var QPN] -> ConflictSet
fromList :: [Var QPN] -> ConflictSet
fromList vars = CS {
conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars]
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}

type ConflictMap = Map (Var QPN) Int

14 changes: 1 addition & 13 deletions cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs
Original file line number Diff line number Diff line change
@@ -1,9 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
#ifdef DEBUG_CONFLICT_SETS
{-# LANGUAGE ImplicitParams #-}
#endif
module Distribution.Solver.Modular.Validate (validateTree) where

-- Validation of the tree.
Expand Down Expand Up @@ -40,10 +36,6 @@ import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent
import Distribution.Types.LibraryName
import Distribution.Types.PkgconfigVersionRange

#ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack)
#endif

-- In practice, most constraints are implication constraints (IF we have made
-- a number of choices, THEN we also have to ensure that). We call constraints
-- that for which the preconditions are fulfilled ACTIVE. We maintain a set
Expand Down Expand Up @@ -450,11 +442,7 @@ extendWithPackageChoice (PI qpn i) ppa =
-- set in the sense the it contains variables that allow us to backjump
-- further. We might apply some heuristics here, such as to change the
-- order in which we check the constraints.
merge ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge :: MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))
| i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1
| otherwise =
Expand Down

0 comments on commit ecc5aa2

Please sign in to comment.