Merge pull request #4122 from grayjay/memory-usage-tests

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

Author: grayjay

appveyor.yml

@@ -44,3 +44,4 @@ build_script:
   - ..\cabal test integration-tests --show-details=streaming --test-option=--pattern=!exec --test-option=--hide-successes
   - ..\cabal test integration-tests2 --show-details=streaming --test-option=--hide-successes
   - ..\cabal test solver-quickcheck --show-details=streaming --test-option=--hide-successes --test-option=--quickcheck-tests=1000
+  - ..\cabal test memory-usage-tests --show-details=streaming

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Distribution.Solver.Modular.Explore
     ( backjump
@@ -60,7 +61,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 = 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,11 +119,9 @@ 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 (DoneF rdm a)                         = \ _  -> succeedWith Success (a, rdm)
+    go (FailF c fr)                          = \ !cm -> failWith (Failure c fr)
+                                                                 (c, updateCM 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,
         W.mapWithKey                                -- when descending ...

cabal-install/Distribution/Solver/Types/Progress.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveFunctor #-}
 module Distribution.Solver.Types.Progress
     ( Progress(..)
     , foldProgress
@@ -14,7 +13,14 @@ import Distribution.Client.Compat.Prelude hiding (fail)
 data Progress step fail done = Step step (Progress step fail done)
                              | Fail fail
                              | Done done
-  deriving (Functor)
+
+-- This Functor instance works around a bug in GHC 7.6.3.
+-- See https://ghc.haskell.org/trac/ghc/ticket/7436#comment:6.
+-- The derived functor instance caused a space leak in the solver.
+instance Functor (Progress step fail) where
+  fmap f (Step s p) = Step s (fmap f p)
+  fmap _ (Fail x)   = Fail x
+  fmap f (Done r)   = Done (f r)
 
 -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two
 -- base cases, one for a final result and one for failure.

cabal-install/cabal-install.cabal

@@ -550,6 +550,74 @@ Test-Suite unit-tests
 
   default-language: Haskell2010
 
+-- Tests to run with a limited stack and 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 -K1K"
+  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]]

travis-script.sh

@@ -113,7 +113,8 @@ timed cabal new-build cabal-install:cabal \
                       cabal-install:integration-tests \
                       cabal-install:integration-tests2 \
                       cabal-install:unit-tests \
-                      cabal-install:solver-quickcheck
+                      cabal-install:solver-quickcheck \
+                      cabal-install:memory-usage-tests
 
 # The integration-tests2 need the hackage index, and need it in the secure
 # format, which is not necessarily the default format of the bootstrap cabal.
@@ -125,6 +126,7 @@ timed ${CABAL_INSTALL_BDIR}/build/cabal/cabal update
 (cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/solver-quickcheck/solver-quickcheck  $TEST_OPTIONS --quickcheck-tests=1000) || exit $?
 (cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests/integration-tests  $TEST_OPTIONS) || exit $?
 (cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/integration-tests2/integration-tests2 $TEST_OPTIONS) || exit $?
+(cd cabal-install && timed ${CABAL_INSTALL_BDIR}/build/memory-usage-tests/memory-usage-tests $TEST_OPTIONS) || exit $?
 
 # Haddock
 (cd cabal-install && timed ${CABAL_INSTALL_SETUP} haddock --builddir=${CABAL_INSTALL_BDIR} ) || exit $?