Solver.hs 10.7 KB
Newer Older
Edsko de Vries's avatar
Edsko de Vries committed
1
2
3
4
5
{-# LANGUAGE CPP #-}
#ifdef DEBUG_TRACETREE
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
6
module Distribution.Solver.Modular.Solver
7
8
9
    ( SolverConfig(..)
    , solve
    ) where
10
11

import Data.Map as M
Edsko de Vries's avatar
Edsko de Vries committed
12
import Data.List as L
13
import Data.Set as S
14
import Distribution.Version
15

16
import Distribution.Compiler (CompilerInfo)
17
import Distribution.Text (display)
18

19
import Distribution.Solver.Types.PackagePath
20
import Distribution.Solver.Types.PackagePreferences
21
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
22
import Distribution.Solver.Types.LabeledPackageConstraint
23
import Distribution.Solver.Types.Settings
24
import Distribution.Solver.Types.Variable
25

26
27
28
29
30
31
32
33
34
35
36
37
import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Builder
import Distribution.Solver.Modular.Cycles
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Explore
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Log
import Distribution.Solver.Modular.Message
import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.Preference as P
import Distribution.Solver.Modular.Validate
import Distribution.Solver.Modular.Linking
Edsko de Vries's avatar
Edsko de Vries committed
38
39
40
import Distribution.Solver.Modular.PSQ (PSQ)
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as PSQ
41
42

import Distribution.Simple.Setup (BooleanFlag(..))
43

Edsko de Vries's avatar
Edsko de Vries committed
44
45
46
#ifdef DEBUG_TRACETREE
import Distribution.Solver.Modular.Flag
import qualified Distribution.Solver.Modular.ConflictSet as CS
47
import qualified Distribution.Solver.Modular.WeightedPSQ as W
Edsko de Vries's avatar
Edsko de Vries committed
48
49
50
51
52
53
54

import Debug.Trace.Tree (gtraceJson)
import Debug.Trace.Tree.Simple
import Debug.Trace.Tree.Generic
import Debug.Trace.Tree.Assoc (Assoc(..))
#endif

Andres Löh's avatar
Andres Löh committed
55
-- | Various options for the modular solver.
56
data SolverConfig = SolverConfig {
57
58
  reorderGoals          :: ReorderGoals,
  countConflicts        :: CountConflicts,
59
60
61
62
  independentGoals      :: IndependentGoals,
  avoidReinstalls       :: AvoidReinstalls,
  shadowPkgs            :: ShadowPkgs,
  strongFlags           :: StrongFlags,
63
  maxBackjumps          :: Maybe Int,
64
  enableBackjumping     :: EnableBackjumping,
65
  solveExecutables      :: SolveExecutables,
66
  goalOrder             :: Maybe (Variable QPN -> Variable QPN -> Ordering)
67
68
}

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
-- | Run all solver phases.
--
-- In principle, we have a valid tree after 'validationPhase', which
-- means that every 'Done' node should correspond to valid solution.
--
-- There is one exception, though, and that is cycle detection, which
-- has been added relatively recently. Cycles are only removed directly
-- before exploration.
--
-- Semantically, there is no difference. Cycle detection, as implemented
-- now, only occurs for 'Done' nodes we encounter during exploration,
-- and cycle detection itself does not change the shape of the tree,
-- it only marks some 'Done' nodes as 'Fail', if they contain cyclic
-- solutions.
--
-- There is a tiny performance impact, however, in doing cycle detection
-- directly after validation. Probably because cycle detection maintains
-- some information, and the various reorderings implemented by
-- 'preferencesPhase' and 'heuristicsPhase' are ever so slightly more
-- costly if that information is already around during the reorderings.
--
-- With the current positioning directly before the 'explorePhase', there
-- seems to be no statistically significant performance impact of cycle
-- detection in the common case where there are no cycles.
--
94
95
96
97
98
99
solve :: SolverConfig                         -- ^ solver parameters
      -> CompilerInfo
      -> Index                                -- ^ all available packages as an index
      -> PkgConfigDb                          -- ^ available pkg-config pkgs
      -> (PN -> PackagePreferences)           -- ^ preferences
      -> Map PN [LabeledPackageConstraint]    -- ^ global constraints
100
      -> Set PN                               -- ^ global goals
101
      -> Log Message (Assignment, RevDepMap)
102
solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
103
  explorePhase     $
Edsko de Vries's avatar
Edsko de Vries committed
104
  detectCycles     $
105
106
107
108
109
110
  heuristicsPhase  $
  preferencesPhase $
  validationPhase  $
  prunePhase       $
  buildPhase
  where
111
    explorePhase     = backjumpAndExplore (enableBackjumping sc) (countConflicts sc)
Edsko de Vries's avatar
Edsko de Vries committed
112
    detectCycles     = traceTree "cycles.json" id . detectCyclesPhase
113
114
115
    heuristicsPhase  =
      let heuristicsTree = traceTree "heuristics.json" id
      in case goalOrder sc of
116
           Nothing -> goalChoiceHeuristics .
117
118
119
120
121
122
123
                      heuristicsTree .
                      P.deferWeakFlagChoices .
                      P.deferSetupChoices .
                      P.preferBaseGoalChoice
           Just order -> P.firstGoal .
                         heuristicsTree .
                         P.sortGoals order
124
125
    preferencesPhase = P.preferLinked .
                       P.preferPackagePreferences userPrefs
Edsko de Vries's avatar
Edsko de Vries committed
126
127
    validationPhase  = traceTree "validated.json" id .
                       P.enforceManualFlags . -- can only be done after user constraints
128
                       P.enforcePackageConstraints userConstraints .
129
                       P.enforceSingleInstanceRestriction .
Edsko de Vries's avatar
Edsko de Vries committed
130
                       validateLinking idx .
131
                       validateTree cinfo idx pkgConfigDB
kristenk's avatar
kristenk committed
132
    prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
133
                       -- packages that can never be "upgraded":
134
135
136
137
                       P.requireInstalled (`elem` [ mkPackageName "base"
                                                  , mkPackageName "ghc-prim"
                                                  , mkPackageName "integer-gmp"
                                                  , mkPackageName "integer-simple"
138
                                                  ])
Edsko de Vries's avatar
Edsko de Vries committed
139
140
    buildPhase       = traceTree "build.json" id
                     $ addLinking
141
                     $ buildTree idx (independentGoals sc) (S.toList userGoals)
Edsko de Vries's avatar
Edsko de Vries committed
142

143
    -- Counting conflicts and reordering goals interferes, as both are strategies to
144
    -- change the order of goals.
145
    --
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
    -- 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.
165
166
167
168
169
170
    --
    goalChoiceHeuristics
      | asBool (reorderGoals sc) && asBool (countConflicts sc) = P.preferReallyEasyGoalChoices
      | asBool (reorderGoals sc)                               = P.preferEasyGoalChoices
      | otherwise                                              = id {- P.firstGoal -}

Edsko de Vries's avatar
Edsko de Vries committed
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
-- | Dump solver tree to a file (in debugging mode)
--
-- This only does something if the @debug-tracetree@ configure argument was
-- given; otherwise this is just the identity function.
traceTree ::
#ifdef DEBUG_TRACETREE
  GSimpleTree a =>
#endif
     FilePath  -- ^ Output file
  -> (a -> a)  -- ^ Function to summarize the tree before dumping
  -> a -> a
#ifdef DEBUG_TRACETREE
traceTree = gtraceJson
#else
traceTree _ _ = id
#endif

#ifdef DEBUG_TRACETREE
189
instance GSimpleTree (Tree d QGoalReason) where
Edsko de Vries's avatar
Edsko de Vries committed
190
191
  fromGeneric = go
    where
192
      go :: Tree d QGoalReason -> SimpleTree
193
194
195
      go (PChoice qpn _     psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList  psq
      go (FChoice _   _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq
      go (SChoice _   _ _   psq) = Node "S" $ Assoc $ L.map (uncurry goFS)      $ psqToList  psq
Edsko de Vries's avatar
Edsko de Vries committed
196
      go (GoalChoice        psq) = Node "G" $ Assoc $ L.map (uncurry goG)       $ PSQ.toList psq
197
      go (Done _rdm _s)          = Node "D" $ Assoc []
Edsko de Vries's avatar
Edsko de Vries committed
198
199
      go (Fail cs _reason)       = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]

200
201
202
      psqToList :: W.WeightedPSQ w k v -> [(k, v)]
      psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList

Edsko de Vries's avatar
Edsko de Vries committed
203
      -- Show package choice
204
      goP :: QPN -> POption -> Tree d QGoalReason -> (String, SimpleTree)
205
      goP _        (POption (I ver _loc) Nothing)  subtree = (display ver, go subtree)
Edsko de Vries's avatar
Edsko de Vries committed
206
207
208
      goP (Q _ pn) (POption _           (Just pp)) subtree = (showQPN (Q pp pn), go subtree)

      -- Show flag or stanza choice
209
      goFS :: Bool -> Tree d QGoalReason -> (String, SimpleTree)
Edsko de Vries's avatar
Edsko de Vries committed
210
211
212
      goFS val subtree = (show val, go subtree)

      -- Show goal choice
213
      goG :: Goal QPN -> Tree d QGoalReason -> (String, SimpleTree)
Edsko de Vries's avatar
Edsko de Vries committed
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
      goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree)

      -- Variation on 'showGR' that produces shorter strings
      -- (Actually, QGoalReason records more info than necessary: we only need
      -- to know the variable that introduced the goal, not the value assigned
      -- to that variable)
      shortGR :: QGoalReason -> String
      shortGR UserGoal               = "user"
      shortGR (PDependency (PI nm _)) = showQPN nm
      shortGR (FDependency nm _)      = showQFN nm
      shortGR (SDependency nm)        = showQSN nm

      -- Show conflict set
      goCS :: ConflictSet QPN -> String
      goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}"
#endif

-- | Replace all goal reasons with a dummy goal reason in the tree
--
-- This is useful for debugging (when experimenting with the impact of GRs)
234
_removeGR :: Tree d QGoalReason -> Tree d QGoalReason
Edsko de Vries's avatar
Edsko de Vries committed
235
236
_removeGR = trav go
  where
237
   go :: TreeF d QGoalReason (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
238
239
240
241
   go (PChoiceF qpn _     psq) = PChoiceF qpn dummy     psq
   go (FChoiceF qfn _ a b psq) = FChoiceF qfn dummy a b psq
   go (SChoiceF qsn _ a   psq) = SChoiceF qsn dummy a   psq
   go (GoalChoiceF        psq) = GoalChoiceF            (goG psq)
242
   go (DoneF rdm s)            = DoneF rdm s
Edsko de Vries's avatar
Edsko de Vries committed
243
244
   go (FailF cs reason)        = FailF cs reason

245
   goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
246
247
248
249
250
251
   goG = PSQ.fromList
       . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))
       . PSQ.toList

   dummy :: QGoalReason
   dummy = PDependency
252
         $ PI (Q (PackagePath DefaultNamespace Unqualified) (mkPackageName "$"))
253
              (I (mkVersion [1]) InRepo)