Commit ca6ddc5a authored by Edsko de Vries's avatar Edsko de Vries
Browse files

Add tracetree support

parent ff5c1c5c
{-# LANGUAGE CPP #-}
#ifdef DEBUG_TRACETREE
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
module Distribution.Solver.Modular.Solver
( SolverConfig(..)
, solve
) where
import Data.Map as M
import Data.List as L
import Data.Version
import Distribution.Compiler (CompilerInfo)
......@@ -24,9 +31,22 @@ import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.Preference as P
import Distribution.Solver.Modular.Validate
import Distribution.Solver.Modular.Linking
import Distribution.Solver.Modular.PSQ (PSQ)
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.PSQ as PSQ
import Distribution.Simple.Setup (BooleanFlag(..))
#ifdef DEBUG_TRACETREE
import Distribution.Solver.Modular.Flag
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Debug.Trace.Tree (gtraceJson)
import Debug.Trace.Tree.Simple
import Debug.Trace.Tree.Generic
import Debug.Trace.Tree.Assoc (Assoc(..))
#endif
-- | Various options for the modular solver.
data SolverConfig = SolverConfig {
preferEasyGoalChoices :: ReorderGoals,
......@@ -73,7 +93,7 @@ solve :: SolverConfig -> -- ^ solver parameters
Log Message (Assignment, RevDepMap)
solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
explorePhase $
detectCyclesPhase$
detectCycles $
heuristicsPhase $
preferencesPhase $
validationPhase $
......@@ -81,15 +101,18 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
buildPhase
where
explorePhase = backjumpAndExplore (enableBackjumping sc)
detectCycles = traceTree "cycles.json" id . detectCyclesPhase
heuristicsPhase = (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)
traceTree "heuristics.json" id .
P.deferWeakFlagChoices .
P.deferSetupChoices .
P.preferBaseGoalChoice .
P.preferLinked
preferencesPhase = P.preferPackagePreferences userPrefs
validationPhase = P.enforceManualFlags . -- can only be done after user constraints
validationPhase = traceTree "validated.json" id .
P.enforceManualFlags . -- can only be done after user constraints
P.enforcePackageConstraints userConstraints .
P.enforceSingleInstanceRestriction .
validateLinking idx .
......@@ -101,4 +124,87 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
, PackageName "integer-gmp"
, PackageName "integer-simple"
])
buildPhase = addLinking $ buildTree idx (independentGoals sc) userGoals
buildPhase = traceTree "build.json" id
$ addLinking
$ buildTree idx (independentGoals sc) userGoals
-- | 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
instance GSimpleTree (Tree QGoalReason) where
fromGeneric = go
where
go :: Tree QGoalReason -> SimpleTree
go (PChoice qpn _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ PSQ.toList psq
go (FChoice _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ PSQ.toList psq
go (SChoice _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ PSQ.toList psq
go (GoalChoice psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq
go (Done _rdm) = Node "D" $ Assoc []
go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)]
-- Show package choice
goP :: QPN -> POption -> Tree QGoalReason -> (String, SimpleTree)
goP _ (POption (I ver _loc) Nothing) subtree = (showVersion ver, go subtree)
goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree)
-- Show flag or stanza choice
goFS :: Bool -> Tree QGoalReason -> (String, SimpleTree)
goFS val subtree = (show val, go subtree)
-- Show goal choice
goG :: Goal QPN -> Tree QGoalReason -> (String, SimpleTree)
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)
_removeGR :: Tree QGoalReason -> Tree QGoalReason
_removeGR = trav go
where
go :: TreeF QGoalReason (Tree QGoalReason) -> TreeF QGoalReason (Tree QGoalReason)
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)
go (DoneF rdm) = DoneF rdm
go (FailF cs reason) = FailF cs reason
goG :: PSQ (Goal QPN) (Tree QGoalReason) -> PSQ (Goal QPN) (Tree QGoalReason)
goG = PSQ.fromList
. L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree))
. PSQ.toList
dummy :: QGoalReason
dummy = PDependency
$ PI (Q (PP DefaultNamespace Unqualified) (PackageName "$"))
(I (Version [1] []) InRepo)
......@@ -142,6 +142,10 @@ Flag debug-conflict-sets
description: Add additional information to ConflictSets
default: False
Flag debug-tracetree
description: Compile in support for tracetree (used to debug the solver)
default: False
executable cabal
main-is: Main.hs
ghc-options: -Wall -fwarn-tabs
......@@ -331,6 +335,10 @@ executable cabal
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
if flag(debug-tracetree)
cpp-options: -DDEBUG_TRACETREE
build-depends: tracetree >= 0.1 && < 0.2
default-language: Haskell2010
-- Small, fast running tests.
......@@ -403,6 +411,10 @@ Test-Suite unit-tests
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
if flag(debug-tracetree)
cpp-options: -DDEBUG_TRACETREE
build-depends: tracetree >= 0.1 && < 0.2
default-language: Haskell2010
-- Slow solver tests
......@@ -462,6 +474,10 @@ Test-Suite solver-quickcheck
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
if flag(debug-tracetree)
cpp-options: -DDEBUG_TRACETREE
build-depends: tracetree >= 0.1 && < 0.2
default-language: Haskell2010
test-suite integration-tests
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment