From 57c01b2a633b137100d43c50f5b37e1cb6cdc2ec Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 14 Mar 2022 17:23:52 -0400
Subject: [PATCH] allow tests to be split for more granularity

Unit tests are the main bulk of runtime, so splitting them into 2 or 3
parts should help.

For now, the number of parts is still 1, because on my 4 core laptop,
2 was a little bit slower, and 3 slower yet. However, this probably does
vary based on the number of cores, so needs to be revisited, and perhaps
made dynamic.

Since each test mode gets split into the specified number of parts,
plus property and remote tests, 2 gives 8 parts, and 3 gives 11 parts.
Load went to maybe 18, so there was probably contention slowing things
down.

So probably it needs to start N workers with some parts, and when a
worker finishes, run it with the next part, until all parts are
processed.

Sponsored-by: Dartmouth College's Datalad project
---
 Test.hs           | 20 ++++++++++++++------
 Test/Framework.hs |  7 ++++---
 2 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/Test.hs b/Test.hs
index b3b4f7197a..58d6b4fd84 100644
--- a/Test.hs
+++ b/Test.hs
@@ -90,7 +90,7 @@ import qualified Utility.Gpg
 
 optParser :: Parser TestOptions
 optParser = TestOptions
-	<$> snd (tastyParser (tests False True mempty))
+	<$> snd (tastyParser (tests 1 False True mempty))
 	<*> switch
 		( long "keep-failures"
 		<> help "preserve repositories on test failure"
@@ -104,11 +104,11 @@ optParser = TestOptions
 runner :: TestOptions -> IO ()
 runner opts = parallelTestRunner opts tests
 
-tests :: Bool -> Bool -> TestOptions -> [TestTree]
-tests crippledfilesystem adjustedbranchok opts = 
+tests :: Int -> Bool -> Bool -> TestOptions -> [TestTree]
+tests n crippledfilesystem adjustedbranchok opts = 
 	properties 
 		: withTestMode remotetestmode Nothing testRemotes
-		: map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes
+		: concatMap mkunittests testmodes
   where
 	testmodes = catMaybes
 		[ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True })
@@ -122,6 +122,9 @@ tests crippledfilesystem adjustedbranchok opts =
 	canadjust v
 		| adjustedbranchok = Just v
 		| otherwise = Nothing
+	mkunittests (d, te) = map 
+		(\uts -> withTestMode te (Just initTests) uts)
+		(unitTests d n)
 
 properties :: TestTree
 properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $
@@ -248,8 +251,8 @@ initTests = testGroup "Init Tests"
 	, testCase "add" test_add
 	]
 
-unitTests :: String -> TestTree
-unitTests note = testGroup ("Unit Tests " ++ note)
+unitTests :: String -> Int -> [TestTree]
+unitTests note numparts = map (testGroup ("Unit Tests " ++ note)) $ sep
 	[ testCase "add dup" test_add_dup
 	, testCase "add extras" test_add_extras
 	, testCase "readonly remote" test_readonly_remote
@@ -328,6 +331,11 @@ unitTests note = testGroup ("Unit Tests " ++ note)
 	, testCase "add subdirs" test_add_subdirs
 	, testCase "addurl" test_addurl
 	]
+  where
+	sep = sep' (replicate numparts [])
+	sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls
+	sep' ps [] = ps
+	sep' [] _ = []
 
 -- this test case creates the main repo
 test_init :: Assertion
diff --git a/Test/Framework.hs b/Test/Framework.hs
index 4a047eb248..b58a919c9e 100644
--- a/Test/Framework.hs
+++ b/Test/Framework.hs
@@ -679,11 +679,12 @@ make_writeable d = void $
  - leave open are closed before finalCleanup is run at the end. This
  - prevents some failures to clean up after the test suite.
  -}
-parallelTestRunner :: TestOptions -> (Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()
+parallelTestRunner :: TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()
 parallelTestRunner opts mkts
 	| fakeSsh opts = runFakeSsh (internalData opts)
 	| otherwise = go =<< Utility.Env.getEnv subenv
   where
+	numparts = 1
 	subenv = "GIT_ANNEX_TEST_SUBPROCESS"
 	go Nothing = do
 		ensuredir tmpdir
@@ -691,7 +692,7 @@ parallelTestRunner opts mkts
 			(toRawFilePath tmpdir)
 			Nothing Nothing False
 		adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
-		let ts = mkts crippledfilesystem adjustedbranchok opts
+		let ts = mkts numparts crippledfilesystem adjustedbranchok opts
 		let warnings = fst (tastyParser ts)
 		unless (null warnings) $ do
 			hPutStrLn stderr "warnings from tasty:"
@@ -722,7 +723,7 @@ parallelTestRunner opts mkts
 	go (Just subenvval) = case readish subenvval of
 		Nothing -> error ("Bad " ++ subenv)
 		Just (n, crippledfilesystem, adjustedbranchok) -> isolateGitConfig $ do
-			let ts = mkts crippledfilesystem adjustedbranchok opts
+			let ts = mkts numparts crippledfilesystem adjustedbranchok opts
 			let t = topLevelTestGroup 
 				-- This group is needed to avoid what
 				-- seems to be a tasty bug which causes a