Solver: Fix space leak in 'addlinking' (issue #2899)

cabal-install/Distribution/Solver/Modular/Builder.hs

@@ -102,17 +102,18 @@ data BuildType =
   | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance
   deriving Show
 
-build :: BuildState -> Tree QGoalReason
-build = ana go
+build :: BuildState -> Tree' QGoalReason
+build = ana' go
   where
-    go :: BuildState -> TreeF QGoalReason BuildState
+    go :: BuildState -> TreeF QGoalReason (() -> BuildState)
 
     -- If we have a choice between many goals, we just record the choice in
     -- the tree. We select each open goal in turn, and before we descend, remove
     -- it from the queue of open goals.
     go bs@(BS { rdeps = rds, open = gs, next = Goals })
       | P.null gs = DoneF rds
-      | otherwise = GoalChoiceF $ P.mapKeys close
+      | otherwise = GoalChoiceF $ addDummyArgs
+                                $ P.mapKeys close
                                 $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
                                 $ P.splits gs
 
@@ -135,7 +136,7 @@ build = ana go
       -- messages though.
       case M.lookup pn idx of
         Nothing  -> PChoiceF qpn gr (P.fromList [])
-        Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) ->
+        Just pis -> PChoiceF qpn gr $ addDummyArgs (P.fromList (L.map (\ (i, info) ->
                                                            (POption i Nothing, bs { next = Instance qpn i info gr }))
                                                          (M.toList pis)))
           -- TODO: data structure conversion is rather ugly here
@@ -145,7 +146,7 @@ build = ana go
     --
     -- TODO: Should we include the flag default in the tree?
     go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
-      FChoiceF qfn gr weak m (P.fromList (reorder b
+      FChoiceF qfn gr weak m $ addDummyArgs (P.fromList (reorder b
         [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
          (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]))
       where
@@ -160,7 +161,7 @@ build = ana go
     -- (try enabling the stanza if possible by moving the True branch first).
 
     go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
-      SChoiceF qsn gr trivial (P.fromList
+      SChoiceF qsn gr trivial $ addDummyArgs $ (P.fromList
         [(False,                                                             bs  { next = Goals }),
          (True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
       where
@@ -174,9 +175,14 @@ build = ana go
       go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)
              { next = Goals })
 
+    addDummyArgs :: P.PSQ k v -> P.PSQ k (() -> v)
+    addDummyArgs = P.map const
+
 -- | Interface to the tree builder. Just takes an index and a list of package names,
--- and computes the initial state and then the tree from there.
-buildTree :: Index -> IndependentGoals -> [PN] -> Tree QGoalReason
+-- and computes the initial state and then the tree from there. All subtrees
+-- take dummy arguments, so that they can be copied in later traversals without
+-- sharing data.
+buildTree :: Index -> IndependentGoals -> [PN] -> Tree' QGoalReason
 buildTree idx (IndependentGoals ind) igs =
     build BS {
         index = idx

cabal-install/Distribution/Solver/Modular/Linking.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.Solver.Modular.Linking (
     addLinking
   , validateLinking
@@ -42,7 +43,7 @@ import Distribution.Solver.Types.ComponentDeps (Component)
 type RelatedGoals = Map (PN, I) [PackagePath]
 type Linker       = Reader RelatedGoals
 
--- | Introduce link nodes into tree tree
+-- | Introduce link nodes into the tree
 --
 -- Linking is a traversal of the solver tree that adapts package choice nodes
 -- and adds the option to link wherever appropriate: Package goals are called
@@ -57,31 +58,45 @@ type Linker       = Reader RelatedGoals
 -- package instance. Whenever we make a choice, we extend the map. Whenever we
 -- find a choice, we look into the map in order to find out what link options we
 -- have to add.
-addLinking :: Tree QGoalReason -> Tree QGoalReason
-addLinking = (`runReader` M.empty) .  cata go
+--
+-- All subtrees of the input tree are functions. 'addLinking' creates linked
+-- nodes from unlinked nodes before applying the functions, which ensures that
+-- the subtrees do not share data. Otherwise, the sharing could cause a space
+-- leak.
+addLinking :: Tree' a -> Tree a
+addLinking = (`runReader` M.empty) . cata' go
   where
-    go :: TreeF QGoalReason (Linker (Tree QGoalReason)) -> Linker (Tree QGoalReason)
+    go :: TreeF a (() -> Linker (Tree a)) -> Linker (Tree a)
 
     -- The only nodes of interest are package nodes
     go (PChoiceF qpn gr cs) = do
       env <- ask
-      cs' <- T.sequence $ P.mapWithKey (goP qpn) cs
-      let newCs = concatMap (linkChoices env qpn) (P.toList cs')
-      return $ PChoice qpn gr (cs' `P.union` P.fromList newCs)
-    go _otherwise =
-      innM _otherwise
+      let linkedCs = concatMap (linkChoices env qpn) (P.toList cs)
+          allCs = cs `P.union` P.fromList linkedCs
+      allCs' <- T.sequence $ P.mapWithKey (goP qpn) $ applyChildren allCs
+      return $ PChoice qpn gr allCs'
+    go (FChoiceF qfn gr t m cs) =
+      FChoice qfn gr t m <$> T.sequence (applyChildren cs)
+    go (SChoiceF qsn gr t   cs) =
+      SChoice qsn gr t   <$> T.sequence (applyChildren cs)
+    go (GoalChoiceF         cs)       =
+      GoalChoice         <$> T.sequence (applyChildren cs)
+    go (DoneF revDepMap)              = return $ Done revDepMap
+    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+
+    applyChildren :: P.PSQ k (() -> v) -> P.PSQ k v
+    applyChildren = P.map ($ ())
 
     -- Recurse underneath package choices. Here we just need to make sure
     -- that we record the package choice so that it is available below
-    goP :: QPN -> POption -> Linker (Tree QGoalReason) -> Linker (Tree QGoalReason)
-    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
-    goP _ _ = alreadyLinked
+    goP :: QPN -> POption -> Linker (Tree a) -> Linker (Tree a)
+    goP (Q pp pn) (POption i _) = local (M.insertWith (++) (pn, i) [pp])
 
-linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption, Tree QGoalReason)]
+linkChoices :: forall a. RelatedGoals -> QPN -> (POption, a) -> [(POption, a)]
 linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
     map aux (M.findWithDefault [] (pn, i) related)
   where
-    aux :: PackagePath -> (POption, Tree QGoalReason)
+    aux :: PackagePath -> (POption, a)
     aux pp = (POption i (Just pp), subtree)
 linkChoices _ _ (POption _ (Just _), _) =
     alreadyLinked
@@ -129,10 +144,10 @@ type Validate = Reader ValidateState
 -- * Linked dependencies,
 -- * Equal flag assignments
 -- * Equal stanza assignments
-validateLinking :: Index -> Tree QGoalReason -> Tree QGoalReason
+validateLinking :: Index -> Tree a -> Tree a
 validateLinking index = (`runReader` initVS) . cata go
   where
-    go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason)
+    go :: TreeF a (Validate (Tree a)) -> Validate (Tree a)
 
     go (PChoiceF qpn gr cs) =
       PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)
@@ -147,7 +162,7 @@ validateLinking index = (`runReader` initVS) . cata go
     go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
 
     -- Package choices
-    goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
+    goP :: QPN -> POption -> Validate (Tree a) -> Validate (Tree a)
     goP qpn@(Q _pp pn) opt@(POption i _) r = do
       vs <- ask
       let PInfo deps _ _ = vsIndex vs ! pn ! i
@@ -157,15 +172,15 @@ validateLinking index = (`runReader` initVS) . cata go
         Right vs'       -> local (const vs') r
 
     -- Flag choices
-    goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
+    goF :: QFN -> Bool -> Validate (Tree a) -> Validate (Tree a)
     goF qfn b r = do
       vs <- ask
       case execUpdateState (pickFlag qfn b) vs of
         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
         Right vs'       -> local (const vs') r
 
     -- Stanza choices (much the same as flag choices)
-    goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
+    goS :: QSN -> Bool -> Validate (Tree a) -> Validate (Tree a)
     goS qsn b r = do
       vs <- ask
       case execUpdateState (pickStanza qsn b) vs of

cabal-install/Distribution/Solver/Modular/Tree.hs

@@ -4,8 +4,11 @@ module Distribution.Solver.Modular.Tree
     , POption(..)
     , Tree(..)
     , TreeF(..)
+    , Tree'(..)
     , ana
+    , ana'
     , cata
+    , cata'
     , choices
     , dchoices
     , inn
@@ -111,6 +114,8 @@ data TreeF a b =
   | FailF       (ConflictSet QPN) FailReason
   deriving (Functor, Foldable, Traversable)
 
+newtype Tree' a = Tree' (TreeF a (() -> Tree' a))
+
 out :: Tree a -> TreeF a (Tree a)
 out (PChoice    p i     ts) = PChoiceF    p i     ts
 out (FChoice    p i b m ts) = FChoiceF    p i b m ts
@@ -119,6 +124,14 @@ out (GoalChoice         ts) = GoalChoiceF         ts
 out (Done       x         ) = DoneF       x
 out (Fail       c x       ) = FailF       c x
 
+out' :: Tree' a -> TreeF a (() -> Tree' a)
+out' (Tree' (PChoiceF    p i     ts)) = PChoiceF    p i     ts
+out' (Tree' (FChoiceF    p i b m ts)) = FChoiceF    p i b m ts
+out' (Tree' (SChoiceF    p i b   ts)) = SChoiceF    p i b   ts
+out' (Tree' (GoalChoiceF         ts)) = GoalChoiceF         ts
+out' (Tree' (DoneF       x         )) = DoneF       x
+out' (Tree' (FailF       c x       )) = FailF       c x
+
 inn :: TreeF a (Tree a) -> Tree a
 inn (PChoiceF    p i     ts) = PChoice    p i     ts
 inn (FChoiceF    p i b m ts) = FChoice    p i b m ts
@@ -127,6 +140,14 @@ inn (GoalChoiceF         ts) = GoalChoice         ts
 inn (DoneF       x         ) = Done       x
 inn (FailF       c x       ) = Fail       c x
 
+inn' :: TreeF a (() -> Tree' a) -> Tree' a
+inn' (PChoiceF    p i     ts) = Tree' $ PChoiceF    p i     ts
+inn' (FChoiceF    p i b m ts) = Tree' $ FChoiceF    p i b m ts
+inn' (SChoiceF    p i b   ts) = Tree' $ SChoiceF    p i b   ts
+inn' (GoalChoiceF         ts) = Tree' $ GoalChoiceF         ts
+inn' (DoneF       x         ) = Tree' $ DoneF       x
+inn' (FailF       c x       ) = Tree' $ FailF       c x
+
 innM :: Monad m => TreeF a (m (Tree a)) -> m (Tree a)
 innM (PChoiceF    p i     ts) = liftM (PChoice    p i    ) (sequence ts)
 innM (FChoiceF    p i b m ts) = liftM (FChoice    p i b m) (sequence ts)
@@ -172,6 +193,9 @@ zeroOrOneChoices (Fail       _ _       ) = True
 cata :: (TreeF a b -> b) -> Tree a -> b
 cata phi x = (phi . fmap (cata phi) . out) x
 
+cata' :: (TreeF a (() -> b) -> b) -> Tree' a -> b
+cata' phi x = (phi . fmap (cata' phi .) . out') x
+
 trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b
 trav psi x = cata (inn . psi) x
 
@@ -182,3 +206,6 @@ para phi = phi . fmap (\ x -> (para phi x, x)) . out
 -- | Anamorphism on trees.
 ana :: (b -> TreeF a b) -> b -> Tree a
 ana psi = inn . fmap (ana psi) . psi
+
+ana' :: (b -> TreeF a (() -> b)) -> b -> Tree' a
+ana' psi = inn' . fmap (ana' psi .) . psi