Add test suite with two basic tests for solver space leaks.

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

@@ -60,7 +60,7 @@ backjump (EnableBackjumping enableBj) var initial xs =
           | otherwise                            = f (csAcc `CS.union` cs) cm'
 
     logBackjump :: ConflictSet QPN -> ConflictMap -> ConflictSetLog a
-    logBackjump cs cm = failWith (Failure cs Backjump) (cs, updateCM initial cm)
+    logBackjump cs cm = cm `seq` failWith (Failure cs Backjump) (cs, updateCM initial cm)
                                    -- 'intial' instead of 'cs' here ---^
                                    -- since we do not want to double-count the
                                    -- additionally accumulated conflicts.
@@ -118,10 +118,10 @@ exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
 
     go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
                                     -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap))
-    go (FailF c fr)                          = \ cm -> let failure = failWith (Failure c fr)
-                                                       in if countConflicts
-                                                          then failure (c, updateCM c cm)
-                                                          else failure (c, cm)
+    go (FailF c fr)                          = \ cm -> let cm' = if countConflicts
+                                                                 then updateCM c cm
+                                                                 else cm
+                                                       in cm' `seq` failWith (Failure c fr) (c, cm')
     go (DoneF rdm a)                         = \ _  -> succeedWith Success (a, rdm)
     go (PChoiceF qpn gr     ts)              =
       backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,

cabal-install/cabal-install.cabal

@@ -550,6 +550,74 @@ Test-Suite unit-tests
 
   default-language: Haskell2010
 
+-- Tests to run with a limited heap size
+Test-Suite memory-usage-tests
+  type: exitcode-stdio-1.0
+  main-is: MemoryUsageTests.hs
+  hs-source-dirs: tests, .
+  ghc-options: -Wall -fwarn-tabs -with-rtsopts=-M4M
+  other-modules:
+    UnitTests.Distribution.Solver.Modular.DSL
+    UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
+    UnitTests.Distribution.Solver.Modular.MemoryUsage
+    UnitTests.Options
+  build-depends:
+        base,
+        async,
+        array,
+        bytestring,
+        Cabal,
+        containers,
+        deepseq,
+        mtl,
+        pretty,
+        process,
+        directory,
+        filepath,
+        hashable,
+        stm,
+        tar,
+        time,
+        HTTP,
+        zlib,
+        binary,
+        random,
+        hackage-security,
+        tagged,
+        tasty,
+        tasty-hunit
+
+  if flag(old-directory)
+    build-depends: old-time
+
+  if flag(network-uri)
+    build-depends: network-uri >= 2.6, network >= 2.6
+  else
+    build-depends: network-uri < 2.6, network < 2.6
+
+  if impl(ghc < 7.6)
+    build-depends: ghc-prim >= 0.2 && < 0.3
+
+  if os(windows)
+    build-depends: Win32
+  else
+    build-depends: unix
+
+  ghc-options: -fno-ignore-asserts
+
+  if !(arch(arm) && impl(ghc < 7.6))
+    ghc-options: -threaded
+
+  if flag(debug-conflict-sets)
+    cpp-options: -DDEBUG_CONFLICT_SETS
+    build-depends: base >= 4.8
+
+  if flag(debug-tracetree)
+      cpp-options: -DDEBUG_TRACETREE
+      build-depends: tracetree >= 0.1 && < 0.2
+
+  default-language: Haskell2010
+
 -- Slow solver tests
 Test-Suite solver-quickcheck
   type: exitcode-stdio-1.0

cabal-install/tests/MemoryUsageTests.hs

@@ -0,0 +1,15 @@
+module Main where
+
+import Test.Tasty
+
+import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage
+
+tests :: TestTree
+tests =
+  testGroup "Memory Usage"
+  [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage"
+        UnitTests.Distribution.Solver.Modular.MemoryUsage.tests
+  ]
+
+main :: IO ()
+main = defaultMain tests

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

@@ -12,6 +12,7 @@ module UnitTests.Distribution.Solver.Modular.DSL (
   , ExampleVersionRange
   , ExamplePkgVersion
   , ExamplePkgName
+  , ExampleFlagName
   , ExampleAvailable(..)
   , ExampleInstalled(..)
   , ExampleQualifier(..)

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs

@@ -4,6 +4,7 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (
     SolverTest
   , SolverResult(..)
   , independentGoals
+  , disableBackjumping
   , goalOrder
   , preferences
   , enableAllTests
@@ -39,6 +40,10 @@ import UnitTests.Options
 independentGoals :: SolverTest -> SolverTest
 independentGoals test = test { testIndepGoals = IndependentGoals True }
 
+disableBackjumping :: SolverTest -> SolverTest
+disableBackjumping test =
+    test { testEnableBackjumping = EnableBackjumping False }
+
 goalOrder :: [ExampleVar] -> SolverTest -> SolverTest
 goalOrder order test = test { testGoalOrder = Just order }
 
@@ -57,6 +62,7 @@ data SolverTest = SolverTest {
   , testTargets        :: [String]
   , testResult         :: SolverResult
   , testIndepGoals     :: IndependentGoals
+  , testEnableBackjumping :: EnableBackjumping
   , testGoalOrder      :: Maybe [ExampleVar]
   , testSoftConstraints :: [ExPreference]
   , testDb             :: ExampleDb
@@ -145,6 +151,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
   , testTargets        = targets
   , testResult         = result
   , testIndepGoals     = IndependentGoals False
+  , testEnableBackjumping = EnableBackjumping True
   , testGoalOrder      = Nothing
   , testSoftConstraints = []
   , testDb             = db
@@ -160,7 +167,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
       let progress = exResolve testDb testSupportedExts
                      testSupportedLangs testPkgConfigDb testTargets
                      Modular Nothing testIndepGoals (ReorderGoals False)
-                     (EnableBackjumping True) testGoalOrder testSoftConstraints
+                     testEnableBackjumping testGoalOrder testSoftConstraints
                      testEnableAllTests
           printMsg msg = if showSolverLog
                          then putStrLn msg

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

@@ -0,0 +1,58 @@
+-- | Tests for detecting space leaks in the dependency solver.
+module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where
+
+import Test.Tasty (TestTree)
+
+import UnitTests.Distribution.Solver.Modular.DSL
+import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
+
+tests :: [TestTree]
+tests = [
+      runTest $ basicTest "basic space leak test"
+    , runTest $ flagsTest "package with many flags"
+    ]
+
+-- | This test solves for n packages that each have two versions. Backjumping
+-- is disabled, so the solver must explore a search tree of size 2^n. It should
+-- fail if memory usage is proportional to the size of the tree.
+basicTest :: String -> SolverTest
+basicTest name =
+    disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure
+  where
+    n :: Int
+    n = 18
+
+    pkgs :: ExampleDb
+    pkgs = map Right $
+           [ exAv "target" 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
+
+-- | This test is similar to 'basicTest', except that it has one package with n
+-- flags, flag-1 through flag-n. The solver assigns flags in order, so it
+-- doesn't discover the unknown dependencies under flag-n until it has assigned
+-- all of the flags. It has to explore the whole search tree.
+flagsTest :: String -> SolverTest
+flagsTest name =
+    disableBackjumping $
+    goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure
+  where
+    n :: Int
+    n = 16
+
+    pkgs :: ExampleDb
+    pkgs = [Right $ exAv "pkg" 1 $
+                [exFlag (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]
+
+                -- The remaining flags have no effect:
+             ++ [exFlag (flagName i) [] [] | i <- [1..n - 1]]
+           ]
+
+    flagName :: Int -> ExampleFlagName
+    flagName x = "flag-" ++ show x
+
+    orderedFlags :: [ExampleVar]
+    orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]]