Skip to content

Commit 5dfae2e

Browse files
grayjaygrayjay
committed
Fix space leaks in dependency solver logging.
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'.
1 parent a0192ee commit 5dfae2e

File tree

2 files changed

+96
-109
lines changed

2 files changed

+96
-109
lines changed

‎cabal-install/Distribution/Client/Dependency/Modular/Log.hs

Lines changed: 55 additions & 84 deletions
Original file line numberDiff line numberDiff line change
@@ -3,14 +3,13 @@ module Distribution.Client.Dependency.Modular.Log
33
, continueWith
44
, failWith
55
, logToProgress
6-
, logToProgress'
7-
, runLogIO
86
, succeedWith
97
, tryWith
108
) where
119

1210
import Control.Applicative
1311
import Data.List as L
12+
import Data.Maybe (isNothing)
1413
import Data.Set as S
1514

1615
import Distribution.Client.Dependency.Types -- from Cabal
@@ -27,98 +26,70 @@ import Distribution.Client.Dependency.Modular.Tree (FailReason(..))
2726
-- Parameterized over the type of actual messages and the final result.
2827
type Log m a = Progress m () a
2928

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

4232
-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
4333
-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
4434
-- limit is 'Just 0', backtracking is completely disabled.
4535
logToProgress :: Maybe Int -> Log Message a -> Progress String String a
4636
logToProgress mbj l = let
47-
(ms, s) = runLog l
48-
-- 'Nothing' for 's' means search tree exhaustively searched and failed
49-
(es, e) = proc 0 ms -- catch first error (always)
50-
-- 'Nothing' in 'e' means no backjump found
51-
(ns, t) = case mbj of
52-
Nothing -> (ms, Nothing)
53-
Just n -> proc n ms
54-
-- 'Nothing' in 't' means backjump limit not reached
55-
-- prefer first error over later error
56-
(exh, r) = case t of
57-
-- backjump limit not reached
58-
Nothing -> case s of
59-
Nothing -> (True, e) -- failed after exhaustive search
60-
Just _ -> (True, Nothing) -- success
61-
-- backjump limit reached; prefer first error
62-
Just _ -> (False, e) -- failed after backjump limit was reached
37+
es = proc (Just 0) l -- catch first error (always)
38+
ms = useFirstError (proc mbj l)
6339
in go es es -- trace for first error
64-
(showMessages (const True) True ns) -- shortened run
65-
r s exh
40+
(showMessages (const True) True ms) -- run with backjump limit applied
6641
where
67-
-- Proc takes the allowed number of backjumps and a list of messages and explores the
68-
-- message list until the maximum number of backjumps has been reached. The log until
69-
-- that point as well as whether we have encountered an error or not are returned.
70-
proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))
71-
proc _ [] = ([], Nothing)
72-
proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _))
73-
| cs == cs' = proc n xs -- repeated backjumps count as one
74-
proc 0 ( Failure cs Backjump : _ ) = ([], Just cs)
75-
proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)
76-
proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs)
77-
78-
-- This function takes a lot of arguments. The first two are both supposed to be
79-
-- the log up to the first error. That's the error that will always be printed in
80-
-- case we do not find a solution. We pass this log twice, because we evaluate it
81-
-- in parallel with the full log, but we also want to retain the reference to its
82-
-- beginning for when we print it. This trick prevents a space leak!
83-
--
84-
-- The third argument is the full log, the fifth and six error conditions.
85-
-- The seventh argument indicates whether the search was exhaustive.
86-
--
87-
-- The order of arguments is important! In particular 's' must not be evaluated
88-
-- unless absolutely necessary. It contains the final result, and if we shortcut
89-
-- with an error due to backjumping, evaluating 's' would still require traversing
90-
-- the entire tree.
91-
go ms (_ : ns) (x : xs) r s exh = Step x (go ms ns xs r s exh)
92-
go ms [] (x : xs) r s exh = Step x (go ms [] xs r s exh)
93-
go ms _ [] (Just cs) _ exh = Fail $
94-
"Could not resolve dependencies:\n" ++
95-
unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
96-
(if exh then "Dependency tree exhaustively searched.\n"
97-
else "Backjump limit reached (" ++ currlimit mbj ++
98-
"change with --max-backjumps or try to run with --reorder-goals).\n")
99-
where currlimit (Just n) = "currently " ++ show n ++ ", "
100-
currlimit Nothing = ""
101-
go _ _ [] _ (Just s) _ = Done s
102-
go _ _ [] _ _ _ = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
103-
104-
logToProgress' :: Log Message a -> Progress String String a
105-
logToProgress' l = let
106-
(ms, r) = runLog l
107-
xs = showMessages (const True) True ms
108-
in go xs r
109-
where
110-
go [x] Nothing = Fail x
111-
go [] Nothing = Fail ""
112-
go [] (Just r) = Done r
113-
go (x:xs) r = Step x (go xs r)
42+
-- Proc takes the allowed number of backjumps and a 'Progress' and explores the
43+
-- messages until the maximum number of backjumps has been reached. It filters out
44+
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
45+
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
46+
-- original success result or replaces the original failure with 'Nothing'.
47+
proc :: Maybe Int -> Progress Message a b -> Progress Message (Maybe (ConflictSet QPN)) b
48+
proc _ (Done x) = Done x
49+
proc _ (Fail _) = Fail Nothing
50+
proc mbj' (Step (Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _)))
51+
| cs == cs' = proc mbj' xs -- repeated backjumps count as one
52+
proc (Just 0) (Step (Failure cs Backjump) _) = Fail (Just cs)
53+
proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs)
54+
proc mbj' (Step x xs) = Step x (proc mbj' xs)
11455

56+
-- Sets the conflict set from the first backjump as the final error, and records
57+
-- whether the search was exhaustive.
58+
useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b
59+
-> Progress Message (Bool, Maybe (ConflictSet QPN)) b
60+
useFirstError = replace Nothing
61+
where
62+
replace _ (Done x) = Done x
63+
replace cs' (Fail cs) = -- 'Nothing' means backjump limit not reached.
64+
-- Prefer first error over later error.
65+
Fail (isNothing cs, cs' <|> cs)
66+
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
67+
replace cs' (Step x xs) = Step x $ replace cs' xs
11568

116-
runLogIO :: Log Message a -> IO (Maybe a)
117-
runLogIO x =
118-
do
119-
let (ms, r) = runLog x
120-
putStr (unlines $ showMessages (const True) True ms)
121-
return r
69+
-- The first two arguments are both supposed to be the log up to the first error.
70+
-- That's the error that will always be printed in case we do not find a solution.
71+
-- We pass this log twice, because we evaluate it in parallel with the full log,
72+
-- but we also want to retain the reference to its beginning for when we print it.
73+
-- This trick prevents a space leak!
74+
--
75+
-- The third argument is the full log, ending with either the solution or the
76+
-- exhaustiveness and first conflict set.
77+
go :: Progress Message a b
78+
-> Progress Message a b
79+
-> Progress String (Bool, Maybe (ConflictSet QPN)) b
80+
-> Progress String String b
81+
go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs)
82+
go ms r (Step x xs) = Step x (go ms r xs)
83+
go ms _ (Fail (exh, Just cs)) = Fail $
84+
"Could not resolve dependencies:\n" ++
85+
unlines (messages $ showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
86+
(if exh then "Dependency tree exhaustively searched.\n"
87+
else "Backjump limit reached (" ++ currlimit mbj ++
88+
"change with --max-backjumps or try to run with --reorder-goals).\n")
89+
where currlimit (Just n) = "currently " ++ show n ++ ", "
90+
currlimit Nothing = ""
91+
go _ _ (Done s) = Done s
92+
go _ _ (Fail (_, Nothing)) = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
12293

12394
failWith :: m -> Log m a
12495
failWith m = Step m (Fail ())

‎cabal-install/Distribution/Client/Dependency/Modular/Message.hs

Lines changed: 41 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -12,8 +12,9 @@ import Distribution.Client.Dependency.Modular.Dependency
1212
import Distribution.Client.Dependency.Modular.Flag
1313
import Distribution.Client.Dependency.Modular.Package
1414
import Distribution.Client.Dependency.Modular.Tree
15+
( FailReason(..), POption(..) )
1516
import Distribution.Client.Dependency.Types
16-
( ConstraintSource(..), showConstraintSource )
17+
( ConstraintSource(..), showConstraintSource, Progress(..) )
1718

1819
data Message =
1920
Enter -- ^ increase indentation level
@@ -37,7 +38,7 @@ data Message =
3738
-- The second argument indicates if the level numbers should be shown. This is
3839
-- recommended for any trace that involves backtracking, because only the level
3940
-- numbers will allow to keep track of backjumps.
40-
showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]
41+
showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b
4142
showMessages p sl = go [] 0
4243
where
4344
-- The stack 'v' represents variables that are currently assigned by the
@@ -47,27 +48,33 @@ showMessages p sl = go [] 0
4748
-- 'Failure', it calls 'atLevel' with the goal variable at the head of the
4849
-- stack so that the predicate can also select messages relating to package
4950
-- goal choices.
50-
go :: [Var QPN] -> Int -> [Message] -> [String]
51-
go _ _ [] = []
51+
go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b
52+
go _ _ (Done x) = Done x
53+
go _ _ (Fail x) = Fail x
5254
-- complex patterns
53-
go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms
54-
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)
55-
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)
56-
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)
57-
go v l (Next (Goal (P qpn) gr) : Failure c fr : ms) =
55+
go v l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
56+
goPReject v l qpn [i] c fr ms
57+
go v l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
58+
(atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
59+
go v l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
60+
(atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
61+
go v l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
62+
(atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)
63+
go v l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =
5864
let v' = add (P qpn) v
5965
in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms)
60-
go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms
66+
go v l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))
67+
| c == c' = go v l ms
6168
-- standard display
62-
go v l (Enter : ms) = go v (l+1) ms
63-
go v l (Leave : ms) = go (drop 1 v) (l-1) ms
64-
go v l (TryP qpn i : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms)
65-
go v l (TryF qfn b : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms)
66-
go v l (TryS qsn b : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms)
67-
go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)
68-
go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log
69-
go v l (Success : ms) = (atLevel v l $ "done") (go v l ms)
70-
go v l (Failure c fr : ms) = (atLevel v l $ showFailure c fr) (go v l ms)
69+
go v l (Step Enter ms) = l `seq` go v (l+1) ms
70+
go v l (Step Leave ms) = v `seq` l `seq` go (drop 1 v) (l-1) ms
71+
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)
72+
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)
73+
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)
74+
go v l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)
75+
go v l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log
76+
go v l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms)
77+
go v l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms)
7178

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

8188
-- special handler for many subsequent package rejections
82-
goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String]
83-
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
84-
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)
89+
goPReject :: [Var QPN]
90+
-> Int
91+
-> QPN
92+
-> [POption]
93+
-> ConflictSet QPN
94+
-> FailReason
95+
-> Progress Message a b
96+
-> Progress String a b
97+
goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
98+
| qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
99+
goPReject v l qpn is c fr ms =
100+
(atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)
85101

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

94110
showQPNPOpt :: QPN -> POption -> String

0 commit comments

Comments
 (0)