Solver: Combine dependencies on the same package in the same 'build-depends'.

This commit is unlikely to have an effect on real packages, but it reduces the
chance of performance problems caused by duplicate dependencies in the solver
quickcheck tests.  It also adds a regression test to memory-usage-tests.

Author: grayjay

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

@@ -3,7 +3,8 @@ module Distribution.Solver.Modular.IndexConversion
     ) where
 
 import Data.List as L
-import Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid as Mon
 import Data.Set as S
@@ -245,12 +246,12 @@ flagInfo (StrongFlags strfl) =
 -- dependencies.
 type IPNs = Set PN
 
--- | Convenience function to delete a 'FlaggedDep' if it's
+-- | Convenience function to delete a 'Dependency' if it's
 -- for a 'PN' that isn't actually real.
-filterIPNs :: IPNs -> Dependency -> FlaggedDep PN -> FlaggedDeps PN
-filterIPNs ipns (Dependency pn _) fd
-    | S.notMember pn ipns = [fd]
-    | otherwise           = []
+filterIPNs :: IPNs -> Dependency -> Maybe Dependency
+filterIPNs ipns d@(Dependency pn _)
+    | S.notMember pn ipns = Just d
+    | otherwise           = Nothing
 
 -- | Convert condition trees to flagged dependencies.  Mutually
 -- recursive with 'convBranch'.  See 'convBranch' for an explanation
@@ -262,8 +263,8 @@ convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -
                 SolveExecutables ->
                 CondTree ConfVar [Dependency] a -> FlaggedDeps PN
 convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) =
-                 concatMap
-                    (\d -> filterIPNs ipns d (D.Simple (convLibDep dr d) comp))             ds  -- unconditional package dependencies
+                 L.map (\d -> D.Simple (convLibDep dr d) comp)
+                       (mergeDeps $ mapMaybe (filterIPNs ipns) ds)                    -- unconditional package dependencies
               ++ L.map (\e -> D.Simple (LDep dr (Ext  e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies
               ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages  bi) -- unconditional language dependencies
               ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies
@@ -273,14 +274,28 @@ convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(Solv
               -- is True.  It might be false in the legacy solver
               -- codepath, in which case there won't be any record of
               -- an executable we need.
-              ++ [ D.Simple (convExeDep dr exeDep) comp
+              ++ L.map (\d -> D.Simple (convExeDep dr d) comp)
+                 (mergeExeDeps
+                 [ exeDep
                  | solveExes'
                  , exeDep <- getAllToolDependencies pkg bi
                  , not $ isInternal pkg exeDep
-                 ]
+                 ])
   where
     bi = getInfo info
 
+    -- Combine dependencies on the same package.
+    mergeDeps :: [Dependency] -> [Dependency]
+    mergeDeps deps =
+        L.map (uncurry Dependency) $ M.toList $
+        M.fromListWith (.&&.) [(p, vr) | Dependency p vr <- deps]
+
+    -- Combine dependencies on the same package and executable.
+    mergeExeDeps :: [ExeDependency] -> [ExeDependency]
+    mergeExeDeps deps =
+        L.map (\((p, exe), vr) -> ExeDependency p exe vr) $ M.toList $
+        M.fromListWith (.&&.) [((p, exe), vr) | ExeDependency p exe vr <- deps]
+
 -- | Branch interpreter.  Mutually recursive with 'convCondTree'.
 --
 -- Here, we try to simplify one of Cabal's condition tree branches into the
@@ -365,8 +380,8 @@ convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBr
                 addFlag v = M.insert fn v flags'
             in extractCommon (t (addFlag True)  (addFlagValue FlagBoth))
                              (f (addFlag False) (addFlagValue FlagBoth))
-                ++ [ Flagged (FN pn fn) (fds ! fn) (t (addFlag True)  (addFlagValue FlagTrue))
-                                                   (f (addFlag False) (addFlagValue FlagFalse)) ]
+                ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True)  (addFlagValue FlagTrue))
+                                                     (f (addFlag False) (addFlagValue FlagFalse)) ]
     go (Var (OS os')) t f
       | os == os'      = t
       | otherwise      = f

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

@@ -11,6 +11,7 @@ tests = [
       runTest $ basicTest "basic space leak test"
     , runTest $ flagsTest "package with many flags"
     , runTest $ issue2899 "issue #2899"
+    , runTest $ duplicateDependencies "duplicate dependencies"
     ]
 
 -- | This test solves for n packages that each have two versions. There is no
@@ -95,3 +96,68 @@ issue2899 name =
 
     goals :: [ExampleVar]
     goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"]
+
+-- | Test for an issue related to lifting dependencies out of conditionals when
+-- converting a PackageDescription to the solver's internal representation.
+--
+-- Issue:
+-- For each conditional and each package B, the solver combined each dependency
+-- on B in the true branch with each dependency on B in the false branch. It
+-- added the combined dependencies to the build-depends outside of the
+-- conditional. Since dependencies could be lifted out of multiple levels of
+-- conditionals, the number of new dependencies could grow exponentially in the
+-- number of levels. For example, the following package generated 4 copies of B
+-- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top
+-- level:
+--
+-- if flag(flag-1)
+--   build-depends: B, B
+-- else
+--   if flag(flag-2)
+--     build-depends: B, B
+--   else
+--     if flag(flag-3)
+--       build-depends: B, B
+--     else
+--       build-depends: B, B
+--
+-- This issue caused the quickcheck tests to start frequently running out of
+-- memory after an optimization that pruned unreachable branches (See PR #4929).
+-- Each problematic test case contained at least one build-depends field with
+-- duplicate dependencies, which was then duplicated under multiple levels of
+-- conditionals by the solver's "buildable: False" transformation, when
+-- "buildable: False" was under multiple flags. Finally, the branch pruning
+-- feature put all build-depends fields in consecutive levels of the condition
+-- tree, causing the solver's representation of the package to follow the
+-- pattern in the example above.
+--
+-- Now the solver avoids this issue by combining all dependencies on the same
+-- package within a build-depends field before lifting them out of conditionals.
+--
+-- This test case is an expanded version of the example above, with library and
+-- build-tool dependencies.
+duplicateDependencies :: String -> SolverTest
+duplicateDependencies name =
+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
+  where
+    copies, depth :: Int
+    copies = 50
+    depth = 50
+
+    pkgs :: ExampleDb
+    pkgs = [
+        Right $ exAv "A" 1 (flaggedDependencies 1)
+      , Right $ exAv "B" 1 [] `withExe` ExExe "exe" []
+      ]
+
+    flaggedDependencies :: Int -> [ExampleDependency]
+    flaggedDependencies n
+        | n > depth = buildDepends
+        | otherwise = [exFlagged (flagName n) buildDepends
+                                              (flaggedDependencies (n + 1))]
+      where
+        buildDepends = replicate copies (ExFix "B" 1)
+                    ++ replicate copies (ExBuildToolFix "B" "exe" 1)
+
+    flagName :: Int -> ExampleFlagName
+    flagName x = "flag-" ++ show x