Merge dependencies more effectively in D.Solver.Modular.IndexConversion.

This commit is a more thorough fix for the problem that
4f7ac10 attempted to fix.  4f7ac10 combined
all dependencies on the same package within the same build-depends or
build-tool-depends field, in order to avoid performance problems in the solver
QuickCheck tests.  That wasn't enough to prevent the solver from creating many
duplicate dependencies when converting the PackageDescription to the
solver-specific format, though.  When a package contained many conditionals that
each contained the same dependency in both branches, the solver lifted those
dependencies out of the conditionals without deduplicating them.

This commit moves the step that merges dependencies after the step that lifts
common dependencies out of conditionals.

Author: grayjay

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

@@ -123,7 +123,7 @@ data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI  -- ^ dependency on a pack
 -- everything needed for creating ConflictSets or describing conflicts in solver
 -- log messages.
 data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza)
-  deriving (Functor, Eq, Show)
+  deriving (Functor, Eq, Ord, Show)
 
 -- | Print the reason that a dependency was introduced.
 showDependencyReason :: DependencyReason QPN -> String

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

@@ -80,7 +80,7 @@ newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool }
 -- | Value shown for a flag in a solver log message. The message can refer to
 -- only the true choice, only the false choice, or both choices.
 data FlagValue = FlagTrue | FlagFalse | FlagBoth
-  deriving (Eq, Show)
+  deriving (Eq, Ord, Show)
 
 showQFNBool :: QFN -> Bool -> String
 showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b

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

@@ -3,8 +3,8 @@ module Distribution.Solver.Modular.IndexConversion
     ) where
 
 import Data.List as L
-import Data.Map (Map)
-import qualified Data.Map as M
+import Distribution.Compat.Map.Strict (Map)
+import qualified Distribution.Compat.Map.Strict as M
 import Data.Maybe
 import Data.Monoid as Mon
 import Data.Set as S
@@ -263,8 +263,14 @@ 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) =
+             -- Merge all library and build-tool dependencies at every level in
+             -- the tree of flagged dependencies. Otherwise 'extractCommon'
+             -- could create duplicate dependencies, and the number of
+             -- duplicates could grow exponentially from the leaves to the root
+             -- of the tree.
+             mergeSimpleDeps $
                  L.map (\d -> D.Simple (convLibDep dr d) comp)
-                       (mergeDeps $ mapMaybe (filterIPNs ipns) ds)                    -- unconditional package dependencies
+                       (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
@@ -274,27 +280,35 @@ 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.
-              ++ L.map (\d -> D.Simple (convExeDep dr d) comp)
-                 (mergeExeDeps
-                 [ exeDep
+              ++ [ D.Simple (convExeDep dr exeDep) comp
                  | 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]
+data SimpleFlaggedDepKey qpn =
+    SimpleFlaggedDepKey (DependencyReason qpn) (Maybe UnqualComponentName) qpn Component
+  deriving (Eq, Ord)
+
+-- | Merge 'Simple' dependencies that apply to the same library or build-tool.
+mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn
+mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged
+  where
+    (merged, unmerged) = L.foldl' f (M.empty, []) deps
+      where
+        f :: Ord qpn
+          => (Map (SimpleFlaggedDepKey qpn) VR, FlaggedDeps qpn)
+          -> FlaggedDep qpn
+          -> (Map (SimpleFlaggedDepKey qpn) VR, FlaggedDeps qpn)
+        f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) =
+            (M.insertWith (.&&.) (SimpleFlaggedDepKey dr mExe qpn comp) vr merged', unmerged')
+        f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged')
+
+    toFlaggedDep :: SimpleFlaggedDepKey qpn -> VR -> FlaggedDep qpn
+    toFlaggedDep (SimpleFlaggedDepKey dr mExe qpn comp) vr =
+        D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp
 
 -- | Branch interpreter.  Mutually recursive with 'convCondTree'.
 --

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

@@ -12,6 +12,7 @@ tests = [
     , runTest $ flagsTest "package with many flags"
     , runTest $ issue2899 "issue #2899"
     , runTest $ duplicateDependencies "duplicate dependencies"
+    , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies"
     ]
 
 -- | This test solves for n packages that each have two versions. There is no
@@ -50,17 +51,14 @@ flagsTest name =
 
     pkgs :: ExampleDb
     pkgs = [Right $ exAv "pkg" 1 $
-                [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]
+                [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]]
 
                 -- The remaining flags have no effect:
-             ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]]
+             ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]]
            ]
 
-    flagName :: Int -> ExampleFlagName
-    flagName x = "flag-" ++ show x
-
     orderedFlags :: [ExampleVar]
-    orderedFlags = [F QualNone "pkg" (flagName i) | i <- [1..n]]
+    orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]]
 
 -- | Test for a space leak caused by sharing of search trees under packages with
 -- link choices (issue #2899).
@@ -132,7 +130,7 @@ issue2899 name =
 -- 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.
+-- package before lifting them out of conditionals.
 --
 -- This test case is an expanded version of the example above, with library and
 -- build-tool dependencies.
@@ -153,11 +151,40 @@ duplicateDependencies name =
     flaggedDependencies :: Int -> [ExampleDependency]
     flaggedDependencies n
         | n > depth = buildDepends
-        | otherwise = [exFlagged (flagName n) buildDepends
-                                              (flaggedDependencies (n + 1))]
+        | otherwise = [exFlagged (numberedFlag 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
+-- | This test is similar to duplicateDependencies, except that every dependency
+-- on B is replaced by a conditional that contains B in both branches. It tests
+-- that the solver doesn't just combine dependencies within one build-depends or
+-- build-tool-depends field; it also needs to combine dependencies after they
+-- are lifted out of conditionals.
+duplicateFlaggedDependencies :: String -> SolverTest
+duplicateFlaggedDependencies name =
+    mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
+  where
+    copies, depth :: Int
+    copies = 15
+    depth = 15
+
+    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 (numberedFlag n) buildDepends
+                                                  (flaggedDependencies (n + 1))]
+      where
+        buildDepends = replicate copies flaggedDep
+        flaggedDep = exFlagged (numberedFlag n) deps deps
+        deps = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1]
+
+numberedFlag :: Int -> ExampleFlagName
+numberedFlag n = "flag-" ++ show n