Merge pull request #4110 from grayjay/issue-2899-2

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

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

+{-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.Solver.Modular.Builder (buildTree) where
 
 -- Building the search tree.
@@ -32,7 +33,15 @@ import Distribution.Solver.Types.ComponentDeps (Component)
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Settings
 
--- | The state needed during the build phase of the search tree.
+-- | All state needed to build and link the search tree. It has a type variable
+-- because the linking phase doesn't need to know about the state used to build
+-- the tree.
+data Linker a = Linker {
+  buildState   :: a,
+  linkingState :: LinkingState
+}
+
+-- | The state needed to build the search tree without creating any linked nodes.
 data BuildState = BS {
   index :: Index,                -- ^ information about packages and their dependencies
   rdeps :: RevDepMap,            -- ^ set of all package goals, completed and open, with reverse dependencies
@@ -41,6 +50,9 @@ data BuildState = BS {
   qualifyOptions :: QualifyOptions -- ^ qualification options
 }
 
+-- | Map of available linking targets.
+type LinkingState = Map (PN, I) [PackagePath]
+
 -- | Extend the set of open goals with the new goals listed.
 --
 -- We also adjust the map of overall goals, and keep track of the
@@ -102,86 +114,154 @@ data BuildType =
   | Instance QPN I PInfo QGoalReason  -- ^ build a tree for a concrete instance
   deriving Show
 
-build :: BuildState -> Tree () QGoalReason
+build :: Linker BuildState -> Tree () QGoalReason
 build = ana go
   where
-    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
-                                $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
-                                $ P.splits gs
-
-    -- If we have already picked a goal, then the choice depends on the kind
-    -- of goal.
-    --
-    -- For a package, we look up the instances available in the global info,
-    -- and then handle each instance in turn.
-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =
-      error "Distribution.Solver.Modular.Builder: build.go called with Ext goal"
-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =
-      error "Distribution.Solver.Modular.Builder: build.go called with Lang goal"
-    go    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =
-      error "Distribution.Solver.Modular.Builder: build.go called with Pkg goal"
-    go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =
-      -- If the package does not exist in the index, we construct an emty PChoiceF node for it
-      -- After all, we have no choices here. Alternatively, we could immediately construct
-      -- a Fail node here, but that would complicate the construction of conflict sets.
-      -- We will probably want to give this case special treatment when generating error
-      -- messages though.
-      case M.lookup pn idx of
-        Nothing  -> PChoiceF qpn gr (W.fromList [])
-        Just pis -> PChoiceF qpn gr (W.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
-
-    -- For a flag, we create only two subtrees, and we create them in the order
-    -- that is indicated by the flag default.
-    --
-    -- 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 (W.fromList
-        [([if b then 0 else 1], True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
-         ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
-      where
-        trivial = L.null t && L.null f
-        weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
-
-    -- For a stanza, we also create only two subtrees. The order is initially
-    -- False, True. This can be changed later by constraints (force enabling
-    -- the stanza by replacing the False branch with failure) or preferences
-    -- (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 (W.fromList
-        [([0], False,                                                             bs  { next = Goals }),
-         ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
-      where
-        trivial = WeakOrTrivial (L.null t)
-
-    -- For a particular instance, we change the state: we update the scope,
-    -- and furthermore we update the set of goals.
-    --
-    -- TODO: We could inline this above.
-    go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =
-      go ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)
-             { next = Goals })
+    go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState)
+    go s = addLinking (linkingState s) $ addChildren (buildState s)
+
+addChildren :: 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.
+addChildren bs@(BS { rdeps = rds, open = gs, next = Goals })
+  | P.null gs = DoneF rds ()
+  | otherwise = GoalChoiceF $ P.mapKeys close
+                            $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' })
+                            $ P.splits gs
+
+-- If we have already picked a goal, then the choice depends on the kind
+-- of goal.
+--
+-- For a package, we look up the instances available in the global info,
+-- and then handle each instance in turn.
+addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Ext _             ) _) _ ) }) =
+  error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal"
+addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Lang _            ) _) _ ) }) =
+  error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal"
+addChildren    (BS { index = _  , next = OneGoal (OpenGoal (Simple (Pkg _ _          ) _) _ ) }) =
+  error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal"
+addChildren bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) =
+  -- If the package does not exist in the index, we construct an emty PChoiceF node for it
+  -- After all, we have no choices here. Alternatively, we could immediately construct
+  -- a Fail node here, but that would complicate the construction of conflict sets.
+  -- We will probably want to give this case special treatment when generating error
+  -- messages though.
+  case M.lookup pn idx of
+    Nothing  -> PChoiceF qpn gr (W.fromList [])
+    Just pis -> PChoiceF qpn gr (W.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
+
+-- For a flag, we create only two subtrees, and we create them in the order
+-- that is indicated by the flag default.
+--
+-- TODO: Should we include the flag default in the tree?
+addChildren bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
+  FChoiceF qfn gr weak m (W.fromList
+    [([if b then 0 else 1], True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }),
+     ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })])
+  where
+    trivial = L.null t && L.null f
+    weak = WeakOrTrivial $ unWeakOrTrivial w || trivial
+
+-- For a stanza, we also create only two subtrees. The order is initially
+-- False, True. This can be changed later by constraints (force enabling
+-- the stanza by replacing the False branch with failure) or preferences
+-- (try enabling the stanza if possible by moving the True branch first).
+
+addChildren bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) =
+  SChoiceF qsn gr trivial (W.fromList
+    [([0], False,                                                             bs  { next = Goals }),
+     ([1], True,  (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })])
+  where
+    trivial = WeakOrTrivial (L.null t)
+
+-- For a particular instance, we change the state: we update the scope,
+-- and furthermore we update the set of goals.
+--
+-- TODO: We could inline this above.
+addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) =
+  addChildren ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs)
+         { next = Goals })
+
+{-------------------------------------------------------------------------------
+  Add linking
+-------------------------------------------------------------------------------}
+
+-- | Introduce link nodes into the tree
+--
+-- Linking is a phase that adapts package choice nodes and adds the option to
+-- link wherever appropriate: Package goals are called "related" if they are for
+-- the same instance of the same package (but have different prefixes). A link
+-- option is available in a package choice node whenever we can choose an
+-- instance that has already been chosen for a related goal at a higher position
+-- in the tree. We only create link options for related goals that are not
+-- themselves linked, because the choice to link to a linked goal is the same as
+-- the choice to link to the target of that goal's linking.
+--
+-- The code here proceeds by maintaining a finite map recording choices that
+-- have been made at higher positions in the tree. For each pair of package name
+-- and instance, it stores the prefixes at which we have made a choice for this
+-- package instance. Whenever we make an unlinked 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.
+--
+-- A separate tree traversal would be simpler. However, 'addLinking' creates
+-- linked nodes from existing unlinked nodes, which leads to sharing between the
+-- nodes. If we copied the nodes when they were full trees of type
+-- 'Tree () QGoalReason', then the sharing would cause a space leak during
+-- exploration of the tree. Instead, we only copy the 'BuildState', which is
+-- relatively small, while the tree is being constructed. See
+-- https://github.com/haskell/cabal/issues/2899
+addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a)
+-- The only nodes of interest are package nodes
+addLinking ls (PChoiceF qpn@(Q pp pn) gr cs) =
+  let linkedCs = fmap (\bs -> Linker bs ls) $
+                 W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs)
+      unlinkedCs = W.mapWithKey goP cs
+      allCs = unlinkedCs `W.union` linkedCs
+
+      -- Recurse underneath package choices. Here we just need to make sure
+      -- that we record the package choice so that it is available below
+      goP :: POption -> a -> Linker a
+      goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls
+      goP _                   _  = alreadyLinked
+  in PChoiceF qpn gr allCs
+addLinking ls t = fmap (\bs -> Linker bs ls) t
+
+linkChoices :: forall a w . LinkingState
+            -> QPN
+            -> (w, POption, a)
+            -> [(w, POption, a)]
+linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =
+    L.map aux (M.findWithDefault [] (pn, i) related)
+  where
+    aux :: PackagePath -> (w, POption, a)
+    aux pp = (weight, POption i (Just pp), subtree)
+linkChoices _ _ (_, POption _ (Just _), _) =
+    alreadyLinked
+
+alreadyLinked :: a
+alreadyLinked = error "addLinking called on tree that already contains linked nodes"
+
+-------------------------------------------------------------------------------
 
 -- | 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
 buildTree idx (IndependentGoals ind) igs =
-    build BS {
-        index = idx
-      , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)
-      , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
-      , next  = Goals
-      , qualifyOptions = defaultQualifyOptions idx
+    build Linker {
+        buildState = BS {
+            index = idx
+          , rdeps = M.fromList (L.map (\ qpn -> (qpn, []))              qpns)
+          , open  = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
+          , next  = Goals
+          , qualifyOptions = defaultQualifyOptions idx
+          }
+      , linkingState = M.empty
       }
   where
     -- Should a top-level goal allowed to be an executable style

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

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.Solver.Modular.Linking (
-    addLinking
-  , validateLinking
+    validateLinking
   ) where
 
 import Prelude ()
@@ -31,67 +29,6 @@ import Distribution.Solver.Types.OptionalStanza
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.ComponentDeps (Component)
 
-{-------------------------------------------------------------------------------
-  Add linking
--------------------------------------------------------------------------------}
-
-type RelatedGoals = Map (PN, I) [PackagePath]
-type Linker       = Reader RelatedGoals
-
--- | 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
--- "related" if they are for the same instance of the same package (but have
--- different prefixes). A link option is available in a package choice node
--- whenever we can choose an instance that has already been chosen for a related
--- goal at a higher position in the tree. We only create link options for
--- related goals that are not themselves linked, because the choice to link to a
--- linked goal is the same as the choice to link to the target of that goal's
--- linking.
---
--- The code here proceeds by maintaining a finite map recording choices that
--- have been made at higher positions in the tree. For each pair of package name
--- and instance, it stores the prefixes at which we have made a choice for this
--- package instance. Whenever we make an unlinked 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 d c -> Tree d c
-addLinking = (`runReader` M.empty) .  cata go
-  where
-    go :: TreeF d c (Linker (Tree d c)) -> Linker (Tree d c)
-
-    -- The only nodes of interest are package nodes
-    go (PChoiceF qpn gr cs) = do
-      env <- ask
-      let linkedCs = W.fromList $ concatMap (linkChoices env qpn) (W.toList cs)
-          unlinkedCs = W.mapWithKey (goP qpn) cs
-      allCs <- T.sequence $ unlinkedCs `W.union` linkedCs
-      return $ PChoice qpn gr allCs
-    go _otherwise =
-      innM _otherwise
-
-    -- 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 d c) -> Linker (Tree d c)
-    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
-    goP _ _ = alreadyLinked
-
-linkChoices :: forall a w . RelatedGoals
-            -> QPN
-            -> (w, POption, a)
-            -> [(w, POption, a)]
-linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) =
-    map aux (M.findWithDefault [] (pn, i) related)
-  where
-    aux :: PackagePath -> (w, POption, a)
-    aux pp = (weight, POption i (Just pp), subtree)
-linkChoices _ _ (_, POption _ (Just _), _) =
-    alreadyLinked
-
-alreadyLinked :: a
-alreadyLinked = error "addLinking called on tree that already contains linked nodes"
-
 {-------------------------------------------------------------------------------
   Validation
 

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

@@ -137,7 +137,6 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
                                                   , mkPackageName "integer-simple"
                                                   ])
     buildPhase       = traceTree "build.json" id
-                     $ addLinking
                      $ buildTree idx (independentGoals sc) (S.toList userGoals)
 
     -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which

cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs

@@ -10,6 +10,7 @@ tests :: [TestTree]
 tests = [
       runTest $ basicTest "basic space leak test"
     , runTest $ flagsTest "package with many flags"
+    , runTest $ issue2899 "issue #2899"
     ]
 
 -- | This test solves for n packages that each have two versions. Backjumping
@@ -56,3 +57,38 @@ flagsTest name =
 
     orderedFlags :: [ExampleVar]
     orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]]
+
+-- | Test for a space leak caused by sharing of search trees under packages with
+-- link choices (issue #2899).
+--
+-- The goal order is fixed so that the solver chooses setup-dep and then
+-- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep
+-- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep
+-- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n
+-- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each
+-- dependency has two versions, the solver must try 2^n combinations when
+-- backjumping is disabled. These combinations create large search trees under
+-- each of the two choices for target-setup.setup-dep. Although the choice to
+-- not link is disallowed by the Single Instance Restriction, the solver doesn't
+-- know that until it has explored (and evaluated) the whole tree under the
+-- choice to link. If the two trees are shared, memory usage spikes.
+issue2899 :: String -> SolverTest
+issue2899 name =
+    disableBackjumping $
+    goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure
+  where
+    n :: Int
+    n = 16
+
+    pkgs :: ExampleDb
+    pkgs = map Right $
+           [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"]
+           , exAv "setup-dep" 1 [ExAny $ pkgName 1]]
+        ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)]
+           | i <- [1..n], v <- [1, 2]]
+
+    pkgName :: Int -> ExamplePkgName
+    pkgName x = "pkg-" ++ show x
+
+    goals :: [ExampleVar]
+    goals = [P None "setup-dep", P (Setup "target") "setup-dep"]