Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
fba4b252
Commit
fba4b252
authored
Apr 26, 2016
by
Andres Löh
Browse files
Count conflicts and prefer goals that contribute to conflicts.
parent
8f32ab44
Changes
3
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Solver/Modular/Explore.hs
View file @
fba4b252
...
...
@@ -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
->
Conflict
SetLog
a
logBackjump
cs
=
failWith
(
Failure
cs
Backjump
)
cs
logBackjump
::
ConflictSet
QPN
->
Conflict
Map
->
(
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
View file @
fba4b252
...
...
@@ -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
View file @
fba4b252
...
...
@@ -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
.
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment