Skip to content

Commit 90c7772

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 bbc3638 commit 90c7772

File tree

2 files changed

+89
-104
lines changed

2 files changed

+89
-104
lines changed

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

Lines changed: 48 additions & 79 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Distribution.Client.Dependency.Modular.Log where
22

33
import Control.Applicative
44
import Data.List as L
5+
import Data.Maybe (isNothing)
56
import Data.Set as S
67

78
import Distribution.Client.Dependency.Types -- from Cabal
@@ -18,98 +19,66 @@ import Distribution.Client.Dependency.Modular.Tree (FailReason(..))
1819
-- Parameterized over the type of actual messages and the final result.
1920
type Log m a = Progress m () a
2021

21-
-- | Turns a log into a list of messages paired with a final result. A final result
22-
-- of 'Nothing' indicates failure. A final result of 'Just' indicates success.
23-
-- Keep in mind that forcing the second component of the returned pair will force the
24-
-- entire log.
25-
runLog :: Log m a -> ([m], Maybe a)
26-
runLog (Done x) = ([], Just x)
27-
runLog (Fail _) = ([], Nothing)
28-
runLog (Step m p) = let
29-
(ms, r) = runLog p
30-
in
31-
(m : ms, r)
22+
messages :: Progress a b c -> [a]
23+
messages = foldProgress (:) (const []) (const [])
3224

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

47+
-- Sets the conflict set from the first backjump as the final error, and records
48+
-- whether the search was exhaustive.
49+
useFirstError :: Progress Message (Maybe (ConflictSet QPN)) b
50+
-> Progress Message (Bool, Maybe (ConflictSet QPN)) b
51+
useFirstError = replace Nothing
52+
where
53+
replace _ (Done x) = Done x
54+
replace cs' (Fail cs) = Fail (isNothing cs, cs' <|> cs)
55+
replace Nothing (Step x@(Failure cs Backjump) xs) = Step x $ replace (Just cs) xs
56+
replace cs' (Step x xs) = Step x $ replace cs' xs
10657

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

11483
failWith :: m -> Log m a
11584
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)