diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,29 @@ # Changelog +## [0.4.2.0] - 2026-10-13 + +### Changed + +* The mutation groups of a run are started most expensive first, so that the + longest-running one is not left to hold a slot on its own at the end. + + +## [0.4.1.0] - 2026-10-13 + +### Changed + +* A control (no-op) mutation is checked against ten of its covering tests + rather than against all of them. + + +## [0.4.0.1] - 2026-10-13 + +### Changed + +* A mutation child is pointed at a directory holding only the mutation it is + asked about, instead of at the run's whole augmented manifest. + + ## [0.4.0.0] - 2026-10-01 ### Fixed diff --git a/src/Test/Syd/Mutation/Driver/Coverage.hs b/src/Test/Syd/Mutation/Driver/Coverage.hs --- a/src/Test/Syd/Mutation/Driver/Coverage.hs +++ b/src/Test/Syd/Mutation/Driver/Coverage.hs @@ -12,6 +12,9 @@ -- merges the results into @manifest-augmented.json@. module Test.Syd.Mutation.Driver.Coverage ( runCoverageMode, + annotateRecord, + controlCoveringTests, + controlCoveringTestLimit, ) where @@ -46,9 +49,10 @@ ( MutationGroup (..), MutationManifest (..), MutationRecord (..), + isControlOperator, readManifestDir, ) -import Test.Syd.Mutation.Runtime (MutationId) +import Test.Syd.Mutation.Runtime (MutationId, renderMutationId) import Test.Syd.Mutation.TestBaselineMap ( TestBaselineMap (..), readTestBaselineMapDirIfExists, @@ -255,30 +259,74 @@ AugmentedManifest [ AugmentedMutationGroup augmented | MutationGroup recs <- mgroups, - let augmented = concatMap (annotateRecord mutationCoverage baselineMap) recs, + let augmented = concatMap (annotateRecord suiteName mutationCoverage baselineMap) recs, not (null augmented) ] - annotateRecord mutationCoverage baselineMap rec = - let coveringTests = - Set.toList $ - Map.findWithDefault Set.empty (mutRecId rec) mutationCoverage - -- Per-mutation timeout (microseconds) = 10 * sum of covering-test - -- baselines, floored at 30s. Tests with no recorded baseline - -- contribute 0; the floor still applies. - coveringBaselineSum :: Word - coveringBaselineSum = - sum [Map.findWithDefault 0 t baselineMap | t <- coveringTests] - timeoutMicros = max defaultTimeoutMicros (10 * coveringBaselineSum) - annotated = - rec - { mutRecCoveringTests = - Just $ Map.singleton suiteName coveringTests - } - in case fromMutationRecord annotated of - Nothing -> [] - Just r -> - [r {augmentedMutationRecordTimeoutMicros = timeoutMicros}] +-- | How many covering tests a control mutation is checked against. +-- +-- A control is expected to survive, so its child cannot stop at a kill: it +-- runs every covering test it is given, which makes an unbounded control the +-- most expensive mutation in a run. What it is for is noticing a suite that +-- cannot be relied on, which the number of controls answers rather than the +-- number of tests each one runs. +controlCoveringTestLimit :: Int +controlCoveringTestLimit = 10 + +-- | Which of a control's covering tests it is checked against. +-- +-- Not the cheapest of them: the fastest tests are the least likely to be the +-- ones a suite cannot be relied on for, so taking those every time would aim +-- the canary away from what it is watching for. A window starting where the +-- mutation's own id lands takes a different few for each control, so a run +-- samples the covering sets across them rather than the same corner of each. +-- +-- Which few follows from the id alone, so the manifest a coverage run writes, +-- and the verdicts a mutation run reaches from it, stay the same on a rerun. +controlCoveringTests :: MutationId -> [TestId] -> [TestId] +controlCoveringTests mid tests = + let total = length tests + offset = sum (map fromEnum (renderMutationId mid)) `mod` max 1 total + in take (min controlCoveringTestLimit total) (drop offset (cycle tests)) + +-- | Annotate one mutation record with the tests that cover it and the budget +-- its child gets. +-- +-- A control keeps only 'controlCoveringTestLimit' of its covering tests, so its +-- budget shrinks with them. +annotateRecord :: + -- | The name of the suite whose coverage this is. + Text -> + -- | Which tests cover each mutation. + Map.Map MutationId (Set.Set TestId) -> + -- | What each test cost on its own. + Map.Map TestId Word -> + MutationRecord -> + [AugmentedMutationRecord] +annotateRecord suiteName mutationCoverage baselineMap rec = + let costOf t = Map.findWithDefault 0 t baselineMap + allCoveringTests = + Set.toList $ + Map.findWithDefault Set.empty (mutRecId rec) mutationCoverage + coveringTests + | isControlOperator (mutRecOperator rec) = + controlCoveringTests (mutRecId rec) allCoveringTests + | otherwise = allCoveringTests + -- Per-mutation timeout (microseconds) = 10 * sum of covering-test + -- baselines, floored at 30s. Tests with no recorded baseline + -- contribute 0; the floor still applies. + coveringBaselineSum :: Word + coveringBaselineSum = sum (map costOf coveringTests) + timeoutMicros = max defaultTimeoutMicros (10 * coveringBaselineSum) + annotated = + rec + { mutRecCoveringTests = + Just $ Map.singleton suiteName coveringTests + } + in case fromMutationRecord annotated of + Nothing -> [] + Just r -> + [r {augmentedMutationRecordTimeoutMicros = timeoutMicros}] emitCoverageEvent :: CoverageProgressEvent -> IO () emitCoverageEvent ev = diff --git a/src/Test/Syd/Mutation/Driver/Mutate.hs b/src/Test/Syd/Mutation/Driver/Mutate.hs --- a/src/Test/Syd/Mutation/Driver/Mutate.hs +++ b/src/Test/Syd/Mutation/Driver/Mutate.hs @@ -13,6 +13,8 @@ -- otherwise it is a survivor (or timed-out). module Test.Syd.Mutation.Driver.Mutate ( runMutationMode, + writeChildTask, + scheduleGroups, UnknownCoveringSuite (..), ) where @@ -23,9 +25,13 @@ import Control.Exception (bracket, bracket_) import qualified Control.Exception as Exception import qualified Data.ByteString as SB +import Data.Foldable (for_) +import Data.List (sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe) +import Data.Ord (Down (..)) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -50,11 +56,17 @@ TimedOutMutation (..), UncoveredMutation (..), readAugmentedManifestFile, + writeAugmentedManifestFile, writeMutationRunReport, ) import Test.Syd.Mutation.Driver.OptParse (SuiteConfig (..)) import Test.Syd.Mutation.Manifest (isControlOperator) import Test.Syd.Mutation.Runtime (renderMutationId) +import Test.Syd.Mutation.TestBaselineMap + ( TestBaselineMap (..), + readTestBaselineMapDirIfExists, + writeTestBaselineMapDir, + ) import Test.Syd.MutationMode.Common ( MutationFailFast (..), MutationResult (..), @@ -93,12 +105,61 @@ reportFile = outDir [relfile|report.txt|] in SB.writeFile (fromAbsFile reportFile) (TE.encodeUtf8 renderedText) +-- | The order to start the mutation groups of a run in, most expensive first. +-- +-- Every group waits for a slot, so the order they are handed to the runner in +-- is the order they get one. A run's groups differ by orders of magnitude: +-- most are a second, a few are minutes, because a group costs what the covering +-- tests it runs cost. Started last, one of those few holds a slot while the +-- rest of them stand idle, so a run ends with one child and a quiet machine. +-- +-- The cost here is what the covering tests cost on their own, which is what +-- the per-mutation budgets are derived from as well. It is an estimate: a +-- mutation stops at the test that kills it, and which test that is cannot be +-- known before running it. Scheduling is all it decides, so an estimate is +-- enough, and it leaves every verdict and the reported order alone. +scheduleGroups :: Maybe TestBaselineMap -> [(Int, AugmentedMutationGroup)] -> [(Int, AugmentedMutationGroup)] +scheduleGroups mBaselines = sortOn (Down . groupCost) + where + costs = maybe Map.empty (\(TestBaselineMap m) -> m) mBaselines + groupCost :: (Int, AugmentedMutationGroup) -> Word + groupCost (_, AugmentedMutationGroup recs) = + sum + [ Map.findWithDefault 0 t costs + | r <- recs, + ts <- Map.elems (augmentedMutationRecordCoveringTests r), + t <- ts + ] + +-- | Write the directory one mutation child is pointed at: the mutation it is +-- being asked about, and the baselines of the tests it will consider. +-- +-- A child needs only its own record, and parsing the whole manifest costs time +-- and memory linear in its size, once per mutation per covering suite. +-- +-- A run with no baselines gets no file at all: an empty map still reorders. +writeChildTask :: Maybe TestBaselineMap -> AugmentedMutationRecord -> Text -> Path Abs Dir -> IO () +writeChildTask mBaselines record suiteName childAugDir = do + writeAugmentedManifestFile + childAugDir + (AugmentedManifest [AugmentedMutationGroup [record]]) + let coveringHere = + Map.findWithDefault + [] + suiteName + (augmentedMutationRecordCoveringTests record) + for_ mBaselines $ \(TestBaselineMap allBaselines) -> + writeTestBaselineMapDir + childAugDir + (TestBaselineMap (Map.restrictKeys allBaselines (Set.fromList coveringHere))) + -- | Parent process: read @manifest-augmented.json@ and spawn one child -- subprocess per mutation per suite that covers it. -- -- Each child receives @--mutation-one --mutation-suite-name -- --mutation-augmented-manifest-dir @ and exits 0 (survived) or --- non-zero (killed). +-- non-zero (killed). The directory is one written for that child alone +-- ('writeChildTask'), not the run's own. -- -- Suites with no covering tests for a given mutation are skipped — running -- a suite with an empty filter would cause sydtest to run all tests. @@ -161,6 +222,8 @@ { unknownCoveringSuiteName = name, unknownCoveringSuiteDeclared = Map.keys suiteConfigs } + -- Read once here rather than once per child; see 'writeChildTask'. + baselines <- readTestBaselineMapDirIfExists augDir n <- case mutationJobs of Just j | j > 0 -> pure (fromIntegral j) _ -> getNumCapabilities @@ -182,7 +245,7 @@ let runGroup' (gix, AugmentedMutationGroup recs) = runOneGroup failFast - (runOne indexByMutationId totalMutations sem) + (runOne baselines indexByMutationId totalMutations sem) ( \r -> atomically $ modifyTVar' groupResultsVar (Map.insertWith (++) gix [r]) @@ -194,7 +257,7 @@ -- 'MutationFailFast' fast-path. mWorkerException <- Exception.try @Exception.SomeException $ do - _ <- mapConcurrently runGroup' (zip [0 :: Int ..] groups) + _ <- mapConcurrently runGroup' (scheduleGroups baselines (zip [0 :: Int ..] groups)) pure () finalGroupResults <- readTVarIO groupResultsVar -- Preserve original group order; reverse each group's results because @@ -258,7 +321,7 @@ -- when fail-fast trips. pure jsonReport where - runOne indexByMutationId totalMutations sem record = + runOne baselines indexByMutationId totalMutations sem record = bracket_ (waitQSem sem) (signalQSem sem) $ do let mid = augmentedMutationRecordId record -- This mutation's stable 1-based position in the manifest. @@ -275,7 +338,7 @@ -- if any child exits non-zero; timed out if any child exceeded -- its budget without any other child killing it first; -- otherwise survived. - outcomes <- runSuitesRetryingOverruns record mid suiteNames attemptsOnOverrun + outcomes <- runSuitesRetryingOverruns baselines record mid suiteNames attemptsOnOverrun -- A control (no-op) mutation is expected to survive. Reinterpret -- its raw outcome: survival is the control passing, a kill or -- timeout is the control failing (the suite is unsound). @@ -311,12 +374,12 @@ -- says nothing, since a busy machine exceeds a budget derived from an -- idle one, and crediting that would let load raise the score. Weakening -- or removing these attempts means revisiting how an overrun is scored. - runSuitesRetryingOverruns record mid suiteNames attemptsLeft = do - outcomes <- mapM (runOneSuite record mid) suiteNames + runSuitesRetryingOverruns baselines record mid suiteNames attemptsLeft = do + outcomes <- mapM (runOneSuite baselines record mid) suiteNames case classifyOutcomes record outcomes of MutationTimedOut _ | attemptsLeft > 1 -> - runSuitesRetryingOverruns record mid suiteNames (attemptsLeft - 1) + runSuitesRetryingOverruns baselines record mid suiteNames (attemptsLeft - 1) _ -> pure outcomes -- Map a control mutation's raw classification onto the control-specific @@ -363,7 +426,7 @@ killingSuiteLog outcomes = listToMaybe [rf | SuiteKilled (Just rf) <- NE.toList outcomes] - runOneSuite record mid suiteName = do + runOneSuite baselines record mid suiteName = do (exe, mResourceDir) <- case Map.lookup suiteName suiteConfigs of Just SuiteConfig {suiteConfigExe, suiteConfigResourceDir} -> pure (fromAbsFile suiteConfigExe, suiteConfigResourceDir) @@ -383,18 +446,22 @@ Nothing -> [] Just limit -> ["+RTS", "-M" ++ limit, "-RTS"] suiteNameStr = T.unpack suiteName - args = - [ "--mutation-one", - renderMutationId mid, - "--mutation-augmented-manifest-dir", - fromAbsDir augDir, - "--mutation-suite-name", - suiteNameStr - ] - ++ rtsArgs - classifySyncExceptionAsKilled $ - withSystemTempDir "mutation-child" $ \tmpDir -> do - let logPath = tmpDir [relfile|child.log|] + -- Only the run of the child is classified: an exception from preparing + -- its directory says nothing about whether a test noticed the mutation. + withSystemTempDir "mutation-child" $ \tmpDir -> do + let logPath = tmpDir [relfile|child.log|] + let childAugDir = tmpDir [reldir|augmented|] + writeChildTask baselines record suiteName childAugDir + let args = + [ "--mutation-one", + renderMutationId mid, + "--mutation-augmented-manifest-dir", + fromAbsDir childAugDir, + "--mutation-suite-name", + suiteNameStr + ] + ++ rtsArgs + classifySyncExceptionAsKilled $ do (outcomeRaw, elapsedMicros) <- withFile (fromAbsFile logPath) WriteMode $ \logHandle -> do let childProc = diff --git a/sydtest-mutation-driver.cabal b/sydtest-mutation-driver.cabal --- a/sydtest-mutation-driver.cabal +++ b/sydtest-mutation-driver.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sydtest-mutation-driver -version: 0.4.0.0 +version: 0.4.2.0 synopsis: Out-of-process mutation testing driver for sydtest. description: Standalone driver executable that orchestrates the coverage and mutation phases of sydtest's mutation testing infrastructure. Spawns instrumented sydtest test suite executables as children. category: Testing