Skip to content

Commit

Permalink
Fix space leaks in dependency solver logging.
Browse files Browse the repository at this point in the history 
This commit removes references to the solver log that prevented it from being
garbage collected.  It also forces evaluation of the current level and variable
stack in 'Message.showMessages'.
  • Loading branch information
@grayjay
grayjay committed Jan 17, 2016
1 parent ecd4760 commit 37f28f2
Show file tree
Hide file tree
Showing 2 changed files with 98 additions and 88 deletions.
118 changes: 55 additions & 63 deletions cabal-install/Distribution/Client/Dependency/Modular/Log.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@ module Distribution.Client.Dependency.Modular.Log

import Control.Applicative
import Data.List as L
import Data.Maybe (isNothing)
import Data.Set as S

import Distribution.Client.Dependency.Types -- from Cabal
Expand All @@ -25,79 +26,70 @@ import Distribution.Client.Dependency.Modular.Tree (FailReason(..))
-- Parameterized over the type of actual messages and the final result.
type Log m a = Progress m () a

-- | Turns a log into a list of messages paired with a final result. A final result
-- of 'Nothing' indicates failure. A final result of 'Just' indicates success.
-- Keep in mind that forcing the second component of the returned pair will force the
-- entire log.
runLog :: Log m a -> ([m], Maybe a)
runLog (Done x) = ([], Just x)
runLog (Fail _) = ([], Nothing)
runLog (Step m p) = let
(ms, r) = runLog p
in
(m : ms, r)
messages :: Progress step fail done -> [step]
messages = foldProgress (:) (const []) (const [])

-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
-- limit is 'Just 0', backtracking is completely disabled.
logToProgress :: Maybe Int -> Log Message a -> Progress String String a
logToProgress mbj l = let
(ms, s) = runLog l
-- 'Nothing' for 's' means search tree exhaustively searched and failed
(es, e) = proc 0 ms -- catch first error (always)
-- 'Nothing' in 'e' means no backjump found
(ns, t) = case mbj of
Nothing -> (ms, Nothing)
Just n -> proc n ms
-- 'Nothing' in 't' means backjump limit not reached
-- prefer first error over later error
(exh, r) = case t of
-- backjump limit not reached
Nothing -> case s of
Nothing -> (True, e) -- failed after exhaustive search
Just _ -> (True, Nothing) -- success
-- backjump limit reached; prefer first error
Just _ -> (False, e) -- failed after backjump limit was reached
es = proc (Just 0) l -- catch first error (always)
ms = useFirstError (proc mbj l)
in go es es -- trace for first error
(showMessages (const True) True ns) -- shortened run
r s exh
(showMessages (const True) True ms) -- run with backjump limit applied
where
-- Proc takes the allowed number of backjumps and a list of messages and explores the
-- message list until the maximum number of backjumps has been reached. The log until
-- that point as well as whether we have encountered an error or not are returned.
proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))
proc _ [] = ([], Nothing)
proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _))
| cs == cs' = proc n xs -- repeated backjumps count as one
proc 0 ( Failure cs Backjump : _ ) = ([], Just cs)
proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)
proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs)
-- Proc takes the allowed number of backjumps and a 'Progress' and explores the
-- messages until the maximum number of backjumps has been reached. It filters out
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
-- original success result or replaces the original failure with 'Nothing'.
proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b
proc _ (Done x) = Done x
proc _ (Fail _) = Fail Nothing
proc mbj' (Step (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))
| cs == cs' = proc mbj' xs -- repeated backjumps count as one
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (Just cs)
proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs)
proc mbj' (Step x xs) = Step x (proc mbj' xs)

-- This function takes a lot of arguments. The first two are both supposed to be
-- the log up to the first error. That's the error that will always be printed in
-- case we do not find a solution. We pass this log twice, because we evaluate it
-- in parallel with the full log, but we also want to retain the reference to its
-- beginning for when we print it. This trick prevents a space leak!
--
-- The third argument is the full log, the fifth and six error conditions.
-- The seventh argument indicates whether the search was exhaustive.
-- Sets the conflict set from the first backjump as the final error, and records
-- whether the search was exhaustive.
useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b
-> Progress Message (Bool, Maybe (ConflictSet QPN)) b
useFirstError = replace Nothing
where
replace _ (Done x) = Done x
replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached.
-- Prefer first error over later error.
Fail (isNothing cs, cs' <|> cs)
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
replace cs' (Step x xs) = Step x $ replace cs' xs

-- The first two arguments are both supposed to be the log up to the first error.
-- That's the error that will always be printed in case we do not find a solution.
-- We pass this log twice, because we evaluate it in parallel with the full log,
-- but we also want to retain the reference to its beginning for when we print it.
-- This trick prevents a space leak!
--
-- The order of arguments is important! In particular 's' must not be evaluated
-- unless absolutely necessary. It contains the final result, and if we shortcut
-- with an error due to backjumping, evaluating 's' would still require traversing
-- the entire tree.
go ms (_ : ns) (x : xs) r s exh = Step x (go ms ns xs r s exh)
go ms [] (x : xs) r s exh = Step x (go ms [] xs r s exh)
go ms _ [] (Just cs) _ exh = Fail $
"Could not resolve dependencies:\n" ++
unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
(if exh then "Dependency tree exhaustively searched.\n"
else "Backjump limit reached (" ++ currlimit mbj ++
"change with --max-backjumps or try to run with --reorder-goals).\n")
where currlimit (Just n) = "currently " ++ show n ++ ", "
currlimit Nothing = ""
go _ _ [] _ (Just s) _ = Done s
go _ _ [] _ _ _ = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
-- The third argument is the full log, ending with either the solution or the
-- exhaustiveness and first conflict set.
go :: Progress Message a b
-> Progress Message a b
-> Progress String (Bool, Maybe (ConflictSet QPN)) b
-> Progress String String b
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
go ms r (Step x xs) = Step x (go ms r xs)
go ms _ (Fail (exh, Just cs)) = Fail $
"Could not resolve dependencies:\n" ++
unlines (messages $ showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
(if exh then "Dependency tree exhaustively searched.\n"
else "Backjump limit reached (" ++ currlimit mbj ++
"change with --max-backjumps or try to run with --reorder-goals).\n")
where currlimit (Just n) = "currently " ++ show n ++ ", "
currlimit Nothing = ""
go _ _ (Done s) = Done s
go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen

failWith :: m -> Log m a
failWith m = Step m (Fail ())
Expand Down
68 changes: 43 additions & 25 deletions cabal-install/Distribution/Client/Dependency/Modular/Message.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
{-# LANGUAGE BangPatterns #-}

module Distribution.Client.Dependency.Modular.Message (
Message(..),
showMessages
Expand All @@ -12,8 +14,9 @@ import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
( FailReason(..), POption(..) )
import Distribution.Client.Dependency.Types
( ConstraintSource(..), showConstraintSource )
( ConstraintSource(..), showConstraintSource, Progress(..) )

data Message =
Enter -- ^ increase indentation level
Expand All @@ -37,7 +40,7 @@ data Message =
-- The second argument indicates if the level numbers should be shown. This is
-- recommended for any trace that involves backtracking, because only the level
-- numbers will allow to keep track of backjumps.
showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]
showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b
showMessages p sl = go [] 0
where
-- The stack 'v' represents variables that are currently assigned by the
Expand All @@ -47,27 +50,33 @@ showMessages p sl = go [] 0
-- 'Failure', it calls 'atLevel' with the goal variable at the head of the
-- stack so that the predicate can also select messages relating to package
-- goal choices.
go :: [Var QPN] -> Int -> [Message] -> [String]
go _ _ [] = []
go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b
go !_ !_ (Done x) = Done x
go !_ !_ (Fail x) = Fail x
-- complex patterns
go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms
go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
go v l (Next (Goal (P qpn) gr) : TryP qpn' i : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)
go v l (Next (Goal (P qpn) gr) : Failure c fr : ms) =
go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
goPReject v l qpn [i] c fr ms
go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
(atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
(atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
(atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)
go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =
let v' = add (P qpn) v
in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)
go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms
go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))
| c == c' = go v l ms
-- standard display
go v l (Enter : ms) = go v (l+1) ms
go v l (Leave : ms) = go (drop 1 v) (l-1) ms
go v l (TryP qpn i : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)
go v l (TryF qfn b : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)
go v l (TryS qsn b : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)
go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)
go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log
go v l (Success : ms) = (atLevel v l $ "done") (go v l ms)
go v l (Failure c fr : ms) = (atLevel v l $ showFailure c fr) (go v l ms)
go !v !l (Step Enter ms) = go v (l+1) ms
go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms
go !v !l (Step (TryP qpn i) ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)
go !v !l (Step (TryF qfn b) ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)
go !v !l (Step (TryS qsn b) ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)
go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)
go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log
go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms)
go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms)

showPackageGoal :: QPN -> QGoalReasonChain -> String
showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGRs gr
Expand All @@ -79,16 +88,25 @@ showMessages p sl = go [] 0
add v vs = simplifyVar v : vs

-- special handler for many subsequent package rejections
goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String]
goPReject v l qpn is c fr (TryP qpn' i : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)
goPReject :: [Var QPN]
-> Int
-> QPN
-> [POption]
-> ConflictSet QPN
-> FailReason
-> Progress Message a b
-> Progress String a b
goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
| qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
goPReject v l qpn is c fr ms =
(atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)

-- write a message, but only if it's relevant; we can also enable or disable the display of the current level
atLevel :: [Var QPN] -> Int -> String -> [String] -> [String]
atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b
atLevel v l x xs
| sl && p v = let s = show l
in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs
| p v = x : xs
in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
| p v = Step x xs
| otherwise = xs

showQPNPOpt :: QPN -> POption -> String
Expand Down

0 comments on commit 37f28f2

Please sign in to comment.