Skip to content

Commit 37f28f2

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 ecd4760 commit 37f28f2

File tree

2 files changed

+98
-88
lines changed

2 files changed

+98
-88
lines changed

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

Lines changed: 55 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Distribution.Client.Dependency.Modular.Log
99

1010
import Control.Applicative
1111
import Data.List as L
12+
import Data.Maybe (isNothing)
1213
import Data.Set as S
1314

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

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

4032
-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps.
4133
-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the
4234
-- limit is 'Just 0', backtracking is completely disabled.
4335
logToProgress :: Maybe Int -> Log Message a -> Progress String String a
4436
logToProgress mbj l = let
45-
(ms, s) = runLog l
46-
-- 'Nothing' for 's' means search tree exhaustively searched and failed
47-
(es, e) = proc 0 ms -- catch first error (always)
48-
-- 'Nothing' in 'e' means no backjump found
49-
(ns, t) = case mbj of
50-
Nothing -> (ms, Nothing)
51-
Just n -> proc n ms
52-
-- 'Nothing' in 't' means backjump limit not reached
53-
-- prefer first error over later error
54-
(exh, r) = case t of
55-
-- backjump limit not reached
56-
Nothing -> case s of
57-
Nothing -> (True, e) -- failed after exhaustive search
58-
Just _ -> (True, Nothing) -- success
59-
-- backjump limit reached; prefer first error
60-
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)
6139
in go es es -- trace for first error
62-
(showMessages (const True) True ns) -- shortened run
63-
r s exh
40+
(showMessages (const True) True ms) -- run with backjump limit applied
6441
where
65-
-- Proc takes the allowed number of backjumps and a list of messages and explores the
66-
-- message list until the maximum number of backjumps has been reached. The log until
67-
-- that point as well as whether we have encountered an error or not are returned.
68-
proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN))
69-
proc _ [] = ([], Nothing)
70-
proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _))
71-
| cs == cs' = proc n xs -- repeated backjumps count as one
72-
proc 0 ( Failure cs Backjump : _ ) = ([], Just cs)
73-
proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs)
74-
proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs)
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)
7555

76-
-- This function takes a lot of arguments. The first two are both supposed to be
77-
-- the log up to the first error. That's the error that will always be printed in
78-
-- case we do not find a solution. We pass this log twice, because we evaluate it
79-
-- in parallel with the full log, but we also want to retain the reference to its
80-
-- beginning for when we print it. This trick prevents a space leak!
81-
--
82-
-- The third argument is the full log, the fifth and six error conditions.
83-
-- The seventh argument indicates whether the search was exhaustive.
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
68+
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!
8474
--
85-
-- The order of arguments is important! In particular 's' must not be evaluated
86-
-- unless absolutely necessary. It contains the final result, and if we shortcut
87-
-- with an error due to backjumping, evaluating 's' would still require traversing
88-
-- the entire tree.
89-
go ms (_ : ns) (x : xs) r s exh = Step x (go ms ns xs r s exh)
90-
go ms [] (x : xs) r s exh = Step x (go ms [] xs r s exh)
91-
go ms _ [] (Just cs) _ exh = Fail $
92-
"Could not resolve dependencies:\n" ++
93-
unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) ++
94-
(if exh then "Dependency tree exhaustively searched.\n"
95-
else "Backjump limit reached (" ++ currlimit mbj ++
96-
"change with --max-backjumps or try to run with --reorder-goals).\n")
97-
where currlimit (Just n) = "currently " ++ show n ++ ", "
98-
currlimit Nothing = ""
99-
go _ _ [] _ (Just s) _ = Done s
100-
go _ _ [] _ _ _ = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen
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
10193

10294
failWith :: m -> Log m a
10395
failWith m = Step m (Fail ())

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

Lines changed: 43 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,5 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
13
module Distribution.Client.Dependency.Modular.Message (
24
Message(..),
35
showMessages
@@ -12,8 +14,9 @@ import Distribution.Client.Dependency.Modular.Dependency
1214
import Distribution.Client.Dependency.Modular.Flag
1315
import Distribution.Client.Dependency.Modular.Package
1416
import Distribution.Client.Dependency.Modular.Tree
17+
( FailReason(..), POption(..) )
1518
import Distribution.Client.Dependency.Types
16-
( ConstraintSource(..), showConstraintSource )
19+
( ConstraintSource(..), showConstraintSource, Progress(..) )
1720

1821
data Message =
1922
Enter -- ^ increase indentation level
@@ -37,7 +40,7 @@ data Message =
3740
-- The second argument indicates if the level numbers should be shown. This is
3841
-- recommended for any trace that involves backtracking, because only the level
3942
-- numbers will allow to keep track of backjumps.
40-
showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String]
43+
showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b
4144
showMessages p sl = go [] 0
4245
where
4346
-- The stack 'v' represents variables that are currently assigned by the
@@ -47,27 +50,33 @@ showMessages p sl = go [] 0
4750
-- 'Failure', it calls 'atLevel' with the goal variable at the head of the
4851
-- stack so that the predicate can also select messages relating to package
4952
-- goal choices.
50-
go :: [Var QPN] -> Int -> [Message] -> [String]
51-
go _ _ [] = []
53+
go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b
54+
go !_ !_ (Done x) = Done x
55+
go !_ !_ (Fail x) = Fail x
5256
-- 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) =
57+
go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
58+
goPReject v l qpn [i] c fr ms
59+
go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
60+
(atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms)
61+
go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =
62+
(atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms)
63+
go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =
64+
(atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms)
65+
go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) =
5866
let v' = add (P qpn) v
5967
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
68+
go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _)))
69+
| c == c' = go v l ms
6170
-- 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)
71+
go !v !l (Step Enter ms) = go v (l+1) ms
72+
go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms
73+
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)
74+
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)
75+
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)
76+
go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms)
77+
go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log
78+
go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms)
79+
go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms)
7180

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

8190
-- 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)
91+
goPReject :: [Var QPN]
92+
-> Int
93+
-> QPN
94+
-> [POption]
95+
-> ConflictSet QPN
96+
-> FailReason
97+
-> Progress Message a b
98+
-> Progress String a b
99+
goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))
100+
| qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms
101+
goPReject v l qpn is c fr ms =
102+
(atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms)
85103

86104
-- 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]
105+
atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b
88106
atLevel v l x xs
89107
| sl && p v = let s = show l
90-
in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs
91-
| p v = x : xs
108+
in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs
109+
| p v = Step x xs
92110
| otherwise = xs
93111

94112
showQPNPOpt :: QPN -> POption -> String

0 commit comments

Comments
 (0)