From 8c866f59934a4f9fb510710ed4253af40be448e4 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 01:35:47 -0700 Subject: [PATCH 01/15] paralleln: add internal lanes so test timer profiles are cleaner --- sandwich/CHANGELOG.md | 4 ++ .../src/Test/Sandwich/Internal/Running.hs | 1 + .../Test/Sandwich/Interpreters/StartTree.hs | 54 +++++++++++---- sandwich/src/Test/Sandwich/ParallelN.hs | 68 +++++++++---------- sandwich/src/Test/Sandwich/Types/RunTree.hs | 9 +++ 5 files changed, 85 insertions(+), 51 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 802e06b9..7ba4c8b5 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -3,6 +3,10 @@ ## Unreleased * TUI: be able to press 'S' to open the speedscope profile in a browser. +* `parallelN` now only creates N test timer profiles instead of one per child. + Breaking: the `parallelSemaphore` label (`QSem`) is replaced by + `parallelismLimit` (`ParallelismLimit`), so `parallelN`'s child spec type + changes. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 199b5635..4d21fb7c 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -123,6 +123,7 @@ baseContextFromOptions options@(Options {..}) = do , baseContextTestTimerProfile = defaultProfileName , baseContextTestTimer = testTimer , baseContextRunId = runId + , baseContextParallelismLimit = Nothing } diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 2201f8c5..671b6707 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -9,6 +9,7 @@ module Test.Sandwich.Interpreters.StartTree ( import Control.Concurrent.MVar +import Control.Concurrent.STM (retry) import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class @@ -55,6 +56,15 @@ baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseCon baseContextFromCommon (RunNodeCommonWithStatus {..}) bc@(BaseContext {}) = bc { baseContextPath = runTreeFolder } +-- | Special hack to modify parts of the 'BaseContext' via an introduce, without +-- needing to track them everywhere. It would be better to track these at the +-- type level. +applyMagicIntroduce :: (HasBaseContext context, Typeable intro) => intro -> context -> context +applyMagicIntroduce intro ctx + | Just (TestTimerProfile t) <- cast intro = modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) + | Just (ParallelismLimit n) <- cast intro = modifyBaseContext ctx (\bc -> bc { baseContextParallelismLimit = Just n }) + | otherwise = ctx + startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result) startTree node@(RunNodeBefore {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon @@ -133,13 +143,7 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do -- TODO: add note about failure in allocation markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason)) Right intro -> do - -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere. - -- It would be better to track the profile at the type level - let ctxFinal = case cast intro of - Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - Nothing -> ctx - - void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) + void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> applyMagicIntroduce intro ctx) ) readIORef result startTree node@(RunNodeIntroduceWith {..}) ctx' = do @@ -358,24 +362,46 @@ runNodesSequentially children ctx = forM (L.filter (shouldRunChild ctx) children) $ \child -> startTree child ctx >>= wait --- | Run a list of children concurrently, cancelling everything on async exception +-- | Run a list of children concurrently, cancelling everything on async exception. +-- If a 'ParallelismLimit' was introduced above us, run at most that many children at a time. runNodesConcurrently :: forall context. HasBaseContext context => RunNodeCommon -> [RunNode context] -> context -> IO [Result] runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) children ctx = flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ - mapM wait =<< sequence [startTree child (modifyTimingProfile ix ctx) + case baseContextParallelismLimit (getBaseContext ctx) of + Nothing -> do + asyncs <- sequence [startTree child (childContext ix ctx) | (child, ix) <- L.zip runnableChildren [0..]] + -- If we stop waiting early because one child threw, take the others down with us; + -- the handler above only fires for async exceptions. + mapM wait asyncs `onException` mapM_ cancel asyncs + Just n -> do + -- Every child gets one of the n lanes, claimed just before it starts and released once + -- it's finished. Since a lane is held for the entire lifetime of a child, the children + -- sharing a lane don't overlap, so they can also share a test timer profile. + lanes <- newTVarIO [0 .. (max 1 n) - 1] + let claimLane = atomically $ readTVar lanes >>= \case + [] -> retry + (lane:rest) -> writeTVar lanes rest >> return lane + let releaseLane lane = atomically $ modifyTVar' lanes (lane :) + + forConcurrently runnableChildren $ \child -> + bracket claimLane releaseLane $ \lane -> do + a <- startTree child (childContext lane ctx) + -- If we get killed while waiting (because a sibling threw), take the child with us, + -- so we don't release the lane while it's still running. + wait a `onException` cancel a where runnableChildren = L.filter (shouldRunChild ctx) children leftPadWithZeros :: Int -> String leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num - modifyTimingProfile :: Int -> context -> context - modifyTimingProfile n = flip modifyBaseContext (modifyTimingProfile' n) - - modifyTimingProfile' :: Int -> BaseContext -> BaseContext - modifyTimingProfile' n bc@(BaseContext {..}) = bc { + -- Give each child its own test timer profile, since they can't share one without messing up + -- the nesting of the profile's frames. Also clear the parallelism limit, since we've consumed it. + childContext :: Int -> context -> context + childContext n = flip modifyBaseContext $ \bc@(BaseContext {..}) -> bc { baseContextTestTimerProfile = baseContextTestTimerProfile <> [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] + , baseContextParallelismLimit = Nothing } markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index bff64c6e..dd41d1f8 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Wrapper around 'parallel' for limiting the threads using a semaphore. +-- | Wrapper around 'parallel' for limiting the number of children that run at once. module Test.Sandwich.ParallelN ( parallelN @@ -16,83 +16,77 @@ module Test.Sandwich.ParallelN ( , defaultParallelNodeOptions -- * Types - , parallelSemaphore - , HasParallelSemaphore + , parallelismLimit + , HasParallelismLimit + , ParallelismLimit(..) ) where -import Control.Concurrent.QSem -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.IO.Unlift import Test.Sandwich.Contexts import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec -import UnliftIO.Exception -- * Types -parallelSemaphore :: Label "parallelSemaphore" QSem -parallelSemaphore = Label +parallelismLimit :: Label "parallelismLimit" ParallelismLimit +parallelismLimit = Label -type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem +type HasParallelismLimit context = HasLabel context "parallelismLimit" ParallelismLimit defaultParallelNodeOptions :: NodeOptions defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } -- * Functions --- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. +-- | Wrapper around 'parallel' which limits the parallelism to N children at a time. parallelN :: ( - MonadUnliftIO m - ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () + Monad m + ) => Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( - MonadUnliftIO m + Monad m ) -- | Node options => NodeOptions - -- | Number of threads + -- | Number of children to run at once -> Int - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelN' nodeOptions n = parallelN'' nodeOptions (liftIO $ newQSem n) +parallelN' nodeOptions n = parallelN'' nodeOptions (pure n) --- | Same as 'parallelN', but extracts the semaphore size from the command line options. +-- | Same as 'parallelN', but extracts the limit from the command line options. parallelNFromArgs :: forall context a m. ( - MonadUnliftIO m, HasCommandLineOptions context a + Monad m, HasCommandLineOptions context a ) - -- | Callback to extract the semaphore size + -- | Callback to extract the limit => (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions parallelNFromArgs' :: forall context a m. ( - MonadUnliftIO m, HasCommandLineOptions context a + Monad m, HasCommandLineOptions context a ) -- | Node options => NodeOptions - -- | Callback to extract the semaphore size + -- | Callback to extract the limit -> (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f - where - f = getContext commandLineOptions >>= (liftIO . newQSem) . getParallelism +parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions (getParallelism <$> getContext commandLineOptions) parallelN'' :: ( - MonadUnliftIO m + Monad m ) => NodeOptions - -> ExampleT context m QSem - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> ExampleT context m Int + -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelN'' nodeOptions makeQSem children = introduce "Introduce parallel semaphore" parallelSemaphore makeQSem (const $ return ()) $ - parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children - where - claimRunSlot f = do - s <- getContext parallelSemaphore - bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) +parallelN'' nodeOptions getLimit children = + -- Introducing a 'ParallelismLimit' is picked up by the 'parallel' node, which + -- uses it to run at most N children at a time (and to share test timer + -- profiles between them). + introduce "Introduce parallelism limit" parallelismLimit (ParallelismLimit <$> getLimit) (const $ return ()) $ + parallel' nodeOptions children diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index 39f06ae8..a46e8d50 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -156,8 +156,17 @@ data BaseContext = BaseContext { , baseContextTestTimerProfile :: T.Text , baseContextTestTimer :: TestTimer , baseContextRunId :: T.Text + -- | Limit on the number of children the next 'parallel' node should run at + -- once. Set by introducing a 'ParallelismLimit', and consumed (and cleared) + -- by the next 'Test.Sandwich.Types.Spec.Parallel'' node below. + , baseContextParallelismLimit :: Maybe Int } +-- | Introduce this value to limit the number of children the next 'parallel' +-- node runs at once. See 'Test.Sandwich.ParallelN.parallelN'. +newtype ParallelismLimit = ParallelismLimit Int + deriving (Show, Eq) + -- | Has-* class for asserting a 'BaseContext' is available. class HasBaseContext a where getBaseContext :: a -> BaseContext From d25ceb7882f1d958a24fee0c7d782f25e04f6135 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 03:46:06 -0700 Subject: [PATCH 02/15] paralleln: restore parallelN semantics, add parallelNWithLanes --- sandwich/CHANGELOG.md | 8 +- sandwich/src/Test/Sandwich/ParallelN.hs | 133 ++++++++++++++++++++---- 2 files changed, 119 insertions(+), 22 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 7ba4c8b5..1dbfe185 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -3,10 +3,10 @@ ## Unreleased * TUI: be able to press 'S' to open the speedscope profile in a browser. -* `parallelN` now only creates N test timer profiles instead of one per child. - Breaking: the `parallelSemaphore` label (`QSem`) is replaced by - `parallelismLimit` (`ParallelismLimit`), so `parallelN`'s child spec type - changes. +* Add `parallelNWithLanes`, which limits a parallel node to N children at a time and gives you N + test timer profiles instead of one per child. Unlike `parallelN`, it bounds only the children of + the node it wraps, so nested `parallel` nodes below it aren't limited. +* Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index dd41d1f8..1f733484 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -4,31 +4,52 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Wrapper around 'parallel' for limiting the number of children that run at once. +-- | Wrappers around 'parallel' for limiting the threads using a semaphore. module Test.Sandwich.ParallelN ( + -- * Limiting with a semaphore parallelN , parallelN' , parallelNFromArgs , parallelNFromArgs' + -- * Limiting with lanes + , parallelNWithLanes + , parallelNWithLanes' + + , parallelNWithLanesFromArgs + , parallelNWithLanesFromArgs' + , defaultParallelNodeOptions -- * Types + , parallelSemaphore + , HasParallelSemaphore + , parallelismLimit , HasParallelismLimit , ParallelismLimit(..) ) where +import Control.Concurrent.QSem +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Test.Sandwich.Contexts import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec +import UnliftIO.Exception -- * Types +parallelSemaphore :: Label "parallelSemaphore" QSem +parallelSemaphore = Label + +type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem + parallelismLimit :: Label "parallelismLimit" ParallelismLimit parallelismLimit = Label @@ -39,54 +60,130 @@ defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold -- * Functions --- | Wrapper around 'parallel' which limits the parallelism to N children at a time. +-- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. +-- +-- The semaphore is claimed by each individual test in the subtree, so the limit applies to the +-- whole subtree, no matter how deeply nested. It's also available to the tests themselves under +-- the 'parallelSemaphore' label, so you can claim it yourself in specs that this function doesn't +-- wrap. +-- +-- Since the tests holding the semaphore change over the life of the node, each child gets its own +-- test timer profile. Use 'parallelNWithLanes' if you'd rather have exactly N profiles. parallelN :: ( - Monad m - ) => Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () + MonadUnliftIO m + ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( + MonadUnliftIO m + ) + -- | Node options + => NodeOptions + -- | Number of threads + -> Int + -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree context m () +parallelN' nodeOptions n = parallelN'' nodeOptions (liftIO $ newQSem n) + +-- | Same as 'parallelN', but extracts the semaphore size from the command line options. +parallelNFromArgs :: forall context a m. ( + MonadUnliftIO m, HasCommandLineOptions context a + ) + -- | Callback to extract the semaphore size + => (CommandLineOptions a -> Int) + -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree context m () +parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions + +parallelNFromArgs' :: forall context a m. ( + MonadUnliftIO m, HasCommandLineOptions context a + ) + -- | Node options + => NodeOptions + -- | Callback to extract the semaphore size + -> (CommandLineOptions a -> Int) + -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree context m () +parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f + where + f = getContext commandLineOptions >>= (liftIO . newQSem) . getParallelism + +parallelN'' :: ( + MonadUnliftIO m + ) + => NodeOptions + -> ExampleT context m QSem + -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree context m () +parallelN'' nodeOptions makeQSem children = introduce "Introduce parallel semaphore" parallelSemaphore makeQSem (const $ return ()) $ + parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children + where + claimRunSlot f = do + s <- getContext parallelSemaphore + bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) + +-- | Wrapper around 'parallel' which runs at most N of its own children at a time. Each child runs +-- in one of N lanes, claimed just before it starts and released once it's finished, and the +-- children sharing a lane share a test timer profile. So you get N profiles rather than one per +-- child, which is much easier to read in the speedscope viewer. +-- +-- Note that this bounds the children of this node only, which is a different thing from what +-- 'parallelN' bounds: +-- +-- * Setup nodes inside a child count against the limit, since a lane is held for the child's +-- whole lifetime. +-- +-- * 'parallel' nodes nested below a child are /not/ bounded. If your tree is assembled from +-- nested parallel nodes (for example by 'Test.Sandwich.TH.getSpecFromFolder' with a parallel +-- combiner), use 'parallelN' instead, or the limit will only apply to the top level. +parallelNWithLanes :: ( + Monad m + ) => Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () +parallelNWithLanes = parallelNWithLanes' defaultParallelNodeOptions + +parallelNWithLanes' :: ( Monad m ) -- | Node options => NodeOptions - -- | Number of children to run at once + -- | Number of lanes -> Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelN' nodeOptions n = parallelN'' nodeOptions (pure n) +parallelNWithLanes' nodeOptions n = parallelNWithLanes'' nodeOptions (pure n) --- | Same as 'parallelN', but extracts the limit from the command line options. -parallelNFromArgs :: forall context a m. ( +-- | Same as 'parallelNWithLanes', but extracts the number of lanes from the command line options. +parallelNWithLanesFromArgs :: forall context a m. ( Monad m, HasCommandLineOptions context a ) - -- | Callback to extract the limit + -- | Callback to extract the number of lanes => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions +parallelNWithLanesFromArgs = parallelNWithLanesFromArgs' @context @a defaultParallelNodeOptions -parallelNFromArgs' :: forall context a m. ( +parallelNWithLanesFromArgs' :: forall context a m. ( Monad m, HasCommandLineOptions context a ) -- | Node options => NodeOptions - -- | Callback to extract the limit + -- | Callback to extract the number of lanes -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions (getParallelism <$> getContext commandLineOptions) +parallelNWithLanesFromArgs' nodeOptions getParallelism = + parallelNWithLanes'' nodeOptions (getParallelism <$> getContext commandLineOptions) -parallelN'' :: ( +parallelNWithLanes'' :: ( Monad m ) => NodeOptions -> ExampleT context m Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelN'' nodeOptions getLimit children = - -- Introducing a 'ParallelismLimit' is picked up by the 'parallel' node, which - -- uses it to run at most N children at a time (and to share test timer - -- profiles between them). +parallelNWithLanes'' nodeOptions getLimit children = + -- Introducing a 'ParallelismLimit' is picked up by the 'parallel' node just below, which uses it + -- to run at most N children at a time (and to share test timer profiles between them). The node + -- clears it for its own children, so a nested 'parallel' doesn't claim it a second time. introduce "Introduce parallelism limit" parallelismLimit (ParallelismLimit <$> getLimit) (const $ return ()) $ parallel' nodeOptions children From 5994cf4c7a7150b984ed76057485191daab06f8b Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 03:54:36 -0700 Subject: [PATCH 03/15] paralleln: limit with a shared pool of lanes instead of a semaphore --- sandwich/CHANGELOG.md | 13 +- .../src/Test/Sandwich/Internal/Running.hs | 2 + .../Test/Sandwich/Interpreters/StartTree.hs | 73 ++++++++--- sandwich/src/Test/Sandwich/ParallelN.hs | 121 ++++++++++++------ sandwich/src/Test/Sandwich/TestTimer.hs | 5 +- sandwich/src/Test/Sandwich/Types/RunTree.hs | 38 +++++- 6 files changed, 191 insertions(+), 61 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 1dbfe185..769fd4dc 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -3,9 +3,16 @@ ## Unreleased * TUI: be able to press 'S' to open the speedscope profile in a browser. -* Add `parallelNWithLanes`, which limits a parallel node to N children at a time and gives you N - test timer profiles instead of one per child. Unlike `parallelN`, it bounds only the children of - the node it wraps, so nested `parallel` nodes below it aren't limited. +* `parallelN` now limits with a pool of lanes rather than a semaphore. The bound is still global + over the whole subtree, including nested `parallel` nodes, but each lane is also a test timer + profile, so you get N profiles instead of one per test. + * Breaking: the `parallelSemaphore` label (`QSem`) is gone. To claim a lane yourself, wrap the + work in `withParallelLane` instead of taking the `QSem`; it's re-entrant, so hooks that apply + at several depths only claim once. + * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already + have. +* Add `parallelNWithLanes`, which limits a single parallel node to N children at a time (setup + included) rather than bounding the subtree. * Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 4d21fb7c..2680e54f 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -124,6 +124,8 @@ baseContextFromOptions options@(Options {..}) = do , baseContextTestTimer = testTimer , baseContextRunId = runId , baseContextParallelismLimit = Nothing + , baseContextLanePool = Nothing + , baseContextCurrentLane = Nothing } diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 671b6707..2d25d8d0 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -59,11 +59,25 @@ baseContextFromCommon (RunNodeCommonWithStatus {..}) bc@(BaseContext {}) = -- | Special hack to modify parts of the 'BaseContext' via an introduce, without -- needing to track them everywhere. It would be better to track these at the -- type level. -applyMagicIntroduce :: (HasBaseContext context, Typeable intro) => intro -> context -> context -applyMagicIntroduce intro ctx - | Just (TestTimerProfile t) <- cast intro = modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - | Just (ParallelismLimit n) <- cast intro = modifyBaseContext ctx (\bc -> bc { baseContextParallelismLimit = Just n }) - | otherwise = ctx +applyMagicIntroduce :: (HasBaseContext context, Typeable intro) => RunNodeCommonWithStatus s l t -> intro -> context -> IO context +applyMagicIntroduce (RunNodeCommonWithStatus {runTreeId}) intro ctx + | Just (TestTimerProfile t) <- cast intro = + pure $ modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) + | Just (ParallelismLimit n) <- cast intro = + pure $ modifyBaseContext ctx (\bc -> bc { baseContextParallelismLimit = Just n }) + | Just (ParallelLanes n) <- cast intro = do + let numLanes = max 1 n + free <- newTVarIO [0 .. numLanes - 1] + baseProfile <- currentTestTimerProfile (getBaseContext ctx) + let names = [baseProfile <> [i|-lane-#{runTreeId}-#{leftPadWithZerosTo numLanes lane}|] + | lane <- [0 .. numLanes - 1]] + pure $ modifyBaseContext ctx (\bc -> bc { baseContextLanePool = Just (LanePool free names) }) + | otherwise = pure ctx + +-- | Pad a number with zeros so that all numbers less than the given total have the same width. +leftPadWithZerosTo :: Int -> Int -> String +leftPadWithZerosTo total num = + L.replicate (L.length (show (total - 1)) - L.length (show num)) '0' <> show num startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result) startTree node@(RunNodeBefore {..}) ctx' = do @@ -143,7 +157,8 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do -- TODO: add note about failure in allocation markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason)) Right intro -> do - void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> applyMagicIntroduce intro ctx) + ctxFinal <- applyMagicIntroduce runNodeCommon intro ctx + void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) ) readIORef result startTree node@(RunNodeIntroduceWith {..}) ctx' = do @@ -282,13 +297,19 @@ runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context runInAsync node ctx action = do let RunNodeCommonWithStatus {..} = runNodeCommon node let bc@(BaseContext {..}) = getBaseContext ctx - let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id let asyncName = T.pack [i|node #{runTreeId}, #{runTreeLabel}|] startTime <- liftIO getCurrentTime mvar <- liftIO newEmptyMVar myAsync <- liftIO $ managedAsyncWithUnmask baseContextRunId asyncName $ \unmask -> do flip withException (recordExceptionInStatus runTreeStatus) $ unmask $ do readMVar mvar + -- Resolve the timing profile now rather than when this node was created, since a lane may + -- have been claimed for us in the meantime. + timerFn <- case runTreeRecordTime of + False -> pure id + True -> do + profile <- currentTestTimerProfile bc + pure $ timeAction' (getTestTimer bc) profile (T.pack runTreeLabel) (result, extraTimingInfo) <- timerFn action endTime <- liftIO getCurrentTime liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime (setupFinishTime extraTimingInfo) (teardownStartTime extraTimingInfo) endTime result @@ -369,7 +390,7 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ case baseContextParallelismLimit (getBaseContext ctx) of Nothing -> do - asyncs <- sequence [startTree child (childContext ix ctx) + asyncs <- sequence [startTree child =<< childContext ix | (child, ix) <- L.zip runnableChildren [0..]] -- If we stop waiting early because one child threw, take the others down with us; -- the handler above only fires for async exceptions. @@ -386,7 +407,7 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre forConcurrently runnableChildren $ \child -> bracket claimLane releaseLane $ \lane -> do - a <- startTree child (childContext lane ctx) + a <- startTree child =<< childContext lane -- If we get killed while waiting (because a sibling threw), take the child with us, -- so we don't release the lane while it's still running. wait a `onException` cancel a @@ -398,11 +419,27 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre -- Give each child its own test timer profile, since they can't share one without messing up -- the nesting of the profile's frames. Also clear the parallelism limit, since we've consumed it. - childContext :: Int -> context -> context - childContext n = flip modifyBaseContext $ \bc@(BaseContext {..}) -> bc { - baseContextTestTimerProfile = baseContextTestTimerProfile <> [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] - , baseContextParallelismLimit = Nothing - } + -- + -- Each child gets a fresh cell for the lane it's holding. If we're already inside a lane, the + -- children inherit it (so they don't try to claim a second one and deadlock), but with their + -- own suffix, since they run concurrently and so can't share a profile either. + childContext :: Int -> IO context + childContext n = do + parentLane <- case baseContextCurrentLane (getBaseContext ctx) of + Nothing -> pure Nothing + Just v -> readTVarIO v + currentLane <- newTVarIO (bumpProfile n <$> parentLane) + return $ modifyBaseContext ctx $ \bc -> bc { + baseContextTestTimerProfile = baseContextTestTimerProfile bc <> suffix n + , baseContextParallelismLimit = Nothing + , baseContextCurrentLane = Just currentLane + } + + suffix :: Int -> T.Text + suffix n = [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] + + bumpProfile :: Int -> LaneState -> LaneState + bumpProfile n ls = ls { laneStateProfile = laneStateProfile ls <> suffix n } markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () markAllChildrenWithResult children baseContext status = do @@ -532,8 +569,12 @@ recordExceptionInStatus status e = do _ -> Done endTime Nothing Nothing endTime ret timed :: forall m a s l t. (MonadUnliftIO m) => RunNodeCommonWithStatus s l t -> Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime) -timed _rnc recordTime bc@(BaseContext {..}) label action = do - let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id +timed _rnc recordTime bc@(BaseContext {}) label action = do + timerFn <- case recordTime of + False -> pure id + True -> do + profile <- currentTestTimerProfile bc + pure $ timeAction' (getTestTimer bc) profile (T.pack label) startTime <- liftIO getCurrentTime ret <- timerFn action diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 1f733484..d4438c10 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -7,14 +7,16 @@ -- | Wrappers around 'parallel' for limiting the threads using a semaphore. module Test.Sandwich.ParallelN ( - -- * Limiting with a semaphore + -- * Limiting with lanes shared by the whole subtree parallelN , parallelN' , parallelNFromArgs , parallelNFromArgs' - -- * Limiting with lanes + , withParallelLane + + -- * Limiting a single parallel node , parallelNWithLanes , parallelNWithLanes' @@ -24,31 +26,35 @@ module Test.Sandwich.ParallelN ( , defaultParallelNodeOptions -- * Types - , parallelSemaphore - , HasParallelSemaphore + , parallelLanes + , HasParallelLanes + , ParallelLanes(..) , parallelismLimit , HasParallelismLimit , ParallelismLimit(..) ) where -import Control.Concurrent.QSem +import Control.Concurrent.STM (retry) import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift +import Control.Monad.Reader +import qualified Data.Text as T import Test.Sandwich.Contexts import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import UnliftIO.Exception +import UnliftIO.STM -- * Types -parallelSemaphore :: Label "parallelSemaphore" QSem -parallelSemaphore = Label +parallelLanes :: Label "parallelLanes" ParallelLanes +parallelLanes = Label -type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem +type HasParallelLanes context = HasLabel context "parallelLanes" ParallelLanes parallelismLimit :: Label "parallelismLimit" ParallelismLimit parallelismLimit = Label @@ -60,67 +66,104 @@ defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold -- * Functions --- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. +-- | Wrapper around 'parallel'. Introduces a pool of N lanes and has each test claim one while it +-- runs, so no more than N tests run at once. -- --- The semaphore is claimed by each individual test in the subtree, so the limit applies to the --- whole subtree, no matter how deeply nested. It's also available to the tests themselves under --- the 'parallelSemaphore' label, so you can claim it yourself in specs that this function doesn't --- wrap. +-- The pool is shared by the whole subtree, no matter how deeply nested, so nested 'parallel' nodes +-- are limited too. Tests in the subtree can claim a lane themselves with 'withParallelLane', which +-- is useful when your specs come from somewhere this function can't wrap directly (such as +-- 'Test.Sandwich.TH.getSpecFromFolder'): claim it wherever the expensive work starts, and +-- everything below that point runs inside the lane. -- --- Since the tests holding the semaphore change over the life of the node, each child gets its own --- test timer profile. Use 'parallelNWithLanes' if you'd rather have exactly N profiles. +-- Each lane is also a test timer profile, so the profile stays readable: you get N profiles rather +-- than one per test. parallelN :: ( - MonadUnliftIO m - ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () + MonadUnliftIO m, HasBaseContext context + ) => Int -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( - MonadUnliftIO m + MonadUnliftIO m, HasBaseContext context ) -- | Node options => NodeOptions - -- | Number of threads + -- | Number of lanes -> Int - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () -parallelN' nodeOptions n = parallelN'' nodeOptions (liftIO $ newQSem n) +parallelN' nodeOptions n = parallelN'' nodeOptions (pure n) --- | Same as 'parallelN', but extracts the semaphore size from the command line options. +-- | Same as 'parallelN', but extracts the number of lanes from the command line options. parallelNFromArgs :: forall context a m. ( - MonadUnliftIO m, HasCommandLineOptions context a + MonadUnliftIO m, HasBaseContext context, HasCommandLineOptions context a ) - -- | Callback to extract the semaphore size + -- | Callback to extract the number of lanes => (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions parallelNFromArgs' :: forall context a m. ( - MonadUnliftIO m, HasCommandLineOptions context a + MonadUnliftIO m, HasBaseContext context, HasCommandLineOptions context a ) -- | Node options => NodeOptions - -- | Callback to extract the semaphore size + -- | Callback to extract the number of lanes -> (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () -parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f - where - f = getContext commandLineOptions >>= (liftIO . newQSem) . getParallelism +parallelNFromArgs' nodeOptions getParallelism = + parallelN'' nodeOptions (getParallelism <$> getContext commandLineOptions) parallelN'' :: ( - MonadUnliftIO m + MonadUnliftIO m, HasBaseContext context ) => NodeOptions - -> ExampleT context m QSem - -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> ExampleT context m Int + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () -parallelN'' nodeOptions makeQSem children = introduce "Introduce parallel semaphore" parallelSemaphore makeQSem (const $ return ()) $ - parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children +parallelN'' nodeOptions getLanes children = + introduce "Introduce parallel lanes" parallelLanes (ParallelLanes <$> getLanes) (const $ return ()) $ + parallel' nodeOptions $ + aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children where - claimRunSlot f = do - s <- getContext parallelSemaphore - bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) + -- Don't time this node: it starts before we have a lane, so its frame would have to go in a + -- profile of its own, which is exactly the clutter the lanes are meant to avoid. + laneNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False } + +-- | Claim one of the lanes introduced by 'parallelN', run the given action, and release it. Blocks +-- until a lane is free. +-- +-- Everything the action runs, at any depth, is timed under the lane's test timer profile. +-- +-- This is a no-op if there are no lanes in scope, or if this part of the tree is already holding +-- one: claiming a second lane while holding one could deadlock, so nesting is allowed and ignored. +withParallelLane :: (MonadUnliftIO m, HasBaseContextMonad context m) => m a -> m a +withParallelLane action = do + BaseContext {..} <- asks getBaseContext + case (baseContextLanePool, baseContextCurrentLane) of + (Nothing, _) -> action + -- We're not underneath a parallel node, so there's no profile to switch; just take a lane. + (Just pool, Nothing) -> bracket (claimLane pool) (releaseLane pool) (const action) + (Just pool, Just currentLane) -> readTVarIO currentLane >>= \case + Just (LaneState {laneStateHeldPools}) | lanePoolFree pool `elem` laneStateHeldPools -> action + heldBefore -> bracket (claimLane pool) (releaseLane pool) $ \lane -> do + let held = LaneState (lanePoolFree pool : maybe [] laneStateHeldPools heldBefore) + (laneProfileName pool lane) + bracket_ (atomically $ writeTVar currentLane (Just held)) + (atomically $ writeTVar currentLane heldBefore) + action + +claimLane :: (MonadIO m) => LanePool -> m Int +claimLane (LanePool {lanePoolFree}) = atomically $ readTVar lanePoolFree >>= \case + [] -> retry + (lane:rest) -> writeTVar lanePoolFree rest >> return lane + +releaseLane :: (MonadIO m) => LanePool -> Int -> m () +releaseLane (LanePool {lanePoolFree}) lane = atomically $ modifyTVar' lanePoolFree (lane :) + +laneProfileName :: LanePool -> Int -> T.Text +laneProfileName (LanePool {lanePoolProfileNames}) lane = lanePoolProfileNames !! lane -- | Wrapper around 'parallel' which runs at most N of its own children at a time. Each child runs -- in one of N lanes, claimed just before it starts and released once it's finished, and the diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index b2d5dac3..763a4039 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -62,8 +62,9 @@ timeAction :: (MonadUnliftIO m, HasBaseContextMonad context m, HasTestTimer cont -> m a timeAction eventName action = do tt <- asks getTestTimer - BaseContext {baseContextTestTimerProfile} <- asks getBaseContext - timeAction' tt baseContextTestTimerProfile eventName action + bc <- asks getBaseContext + profile <- currentTestTimerProfile bc + timeAction' tt profile eventName action -- | Time a given action with a given profile name and event name. Use when you -- want to manually specify the profile name. diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index a46e8d50..7f6edb7b 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -160,13 +160,49 @@ data BaseContext = BaseContext { -- once. Set by introducing a 'ParallelismLimit', and consumed (and cleared) -- by the next 'Test.Sandwich.Types.Spec.Parallel'' node below. , baseContextParallelismLimit :: Maybe Int + -- | Lanes shared by everything below this point, claimed with + -- 'Test.Sandwich.ParallelN.withParallelLane'. Set by introducing 'ParallelLanes'. + , baseContextLanePool :: Maybe LanePool + -- | The lanes held on this branch of the tree, if any. Concurrent branches always get their + -- own cell, so only one thread writes this at a time. + , baseContextCurrentLane :: Maybe (TVar (Maybe LaneState)) } -- | Introduce this value to limit the number of children the next 'parallel' --- node runs at once. See 'Test.Sandwich.ParallelN.parallelN'. +-- node runs at once. See 'Test.Sandwich.ParallelN.parallelNWithLanes'. newtype ParallelismLimit = ParallelismLimit Int deriving (Show, Eq) +-- | Introduce this value to make a pool of N lanes available to the spec tree below, to be +-- claimed with 'Test.Sandwich.ParallelN.withParallelLane'. See 'Test.Sandwich.ParallelN.parallelN'. +newtype ParallelLanes = ParallelLanes Int + deriving (Show, Eq) + +-- | A pool of lanes. A lane is held by one part of the tree at a time, and carries a test timer +-- profile name, so everything that runs in it shares a profile. +data LanePool = LanePool { + lanePoolFree :: TVar [Int] + , lanePoolProfileNames :: [T.Text] + } + +-- | The lanes held on one branch of the tree. +data LaneState = LaneState { + -- | The pools we're already holding a lane from. Claiming a second lane from the same pool + -- would deadlock, since we'd be waiting for a lane that only we can release. + laneStateHeldPools :: [TVar [Int]] + -- | The test timer profile for the innermost lane we hold. + , laneStateProfile :: T.Text + } + +-- | The test timer profile to record frames under right now: the lane's profile if this branch is +-- holding one, and the node's own profile otherwise. +currentTestTimerProfile :: MonadIO m => BaseContext -> m T.Text +currentTestTimerProfile (BaseContext {..}) = case baseContextCurrentLane of + Nothing -> pure baseContextTestTimerProfile + Just v -> liftIO (readTVarIO v) >>= \case + Just (LaneState {laneStateProfile}) -> pure laneStateProfile + Nothing -> pure baseContextTestTimerProfile + -- | Has-* class for asserting a 'BaseContext' is available. class HasBaseContext a where getBaseContext :: a -> BaseContext From 8caab1f3ed059cb4e185fc41500f0f5b3ff1cbf6 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 04:05:22 -0700 Subject: [PATCH 04/15] paralleln: keep handing out the pool's semaphore as parallelSemaphore --- sandwich/CHANGELOG.md | 8 +-- .../Test/Sandwich/Interpreters/StartTree.hs | 4 +- sandwich/src/Test/Sandwich/ParallelN.hs | 49 ++++++++++++++----- sandwich/src/Test/Sandwich/Types/RunTree.hs | 8 ++- 4 files changed, 53 insertions(+), 16 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 769fd4dc..6a1a6a40 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -6,9 +6,11 @@ * `parallelN` now limits with a pool of lanes rather than a semaphore. The bound is still global over the whole subtree, including nested `parallel` nodes, but each lane is also a test timer profile, so you get N profiles instead of one per test. - * Breaking: the `parallelSemaphore` label (`QSem`) is gone. To claim a lane yourself, wrap the - work in `withParallelLane` instead of taking the `QSem`; it's re-entrant, so hooks that apply - at several depths only claim once. + * The `parallelSemaphore` label still hands out a `QSem`, and it's the pool's own semaphore, so + claiming it directly is bounded by the same thing. To also get the lane's timer profile (and + re-entrancy, for hooks that apply at several depths), claim with `withParallelLane` instead. + * `parallelN`'s child spec type has an extra `parallelLanes` label in it, which is inferred for + specs that are polymorphic in their context. * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already have. * Add `parallelNWithLanes`, which limits a single parallel node to N children at a time (setup diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 2d25d8d0..48a38fa3 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -9,6 +9,7 @@ module Test.Sandwich.Interpreters.StartTree ( import Control.Concurrent.MVar +import Control.Concurrent.QSem import Control.Concurrent.STM (retry) import qualified Control.Exception as E import Control.Monad @@ -67,11 +68,12 @@ applyMagicIntroduce (RunNodeCommonWithStatus {runTreeId}) intro ctx pure $ modifyBaseContext ctx (\bc -> bc { baseContextParallelismLimit = Just n }) | Just (ParallelLanes n) <- cast intro = do let numLanes = max 1 n + sem <- newQSem numLanes free <- newTVarIO [0 .. numLanes - 1] baseProfile <- currentTestTimerProfile (getBaseContext ctx) let names = [baseProfile <> [i|-lane-#{runTreeId}-#{leftPadWithZerosTo numLanes lane}|] | lane <- [0 .. numLanes - 1]] - pure $ modifyBaseContext ctx (\bc -> bc { baseContextLanePool = Just (LanePool free names) }) + pure $ modifyBaseContext ctx (\bc -> bc { baseContextLanePool = Just (LanePool sem free names) }) | otherwise = pure ctx -- | Pad a number with zeros so that all numbers less than the given total have the same width. diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index d4438c10..bdc3cd52 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -26,6 +26,9 @@ module Test.Sandwich.ParallelN ( , defaultParallelNodeOptions -- * Types + , parallelSemaphore + , HasParallelSemaphore + , parallelLanes , HasParallelLanes , ParallelLanes(..) @@ -35,6 +38,7 @@ module Test.Sandwich.ParallelN ( , ParallelismLimit(..) ) where +import Control.Concurrent.QSem import Control.Concurrent.STM (retry) import Control.Monad import Control.Monad.IO.Class @@ -51,6 +55,11 @@ import UnliftIO.STM -- * Types +parallelSemaphore :: Label "parallelSemaphore" QSem +parallelSemaphore = Label + +type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem + parallelLanes :: Label "parallelLanes" ParallelLanes parallelLanes = Label @@ -77,9 +86,14 @@ defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold -- -- Each lane is also a test timer profile, so the profile stays readable: you get N profiles rather -- than one per test. +-- +-- The bound is also available as a plain 'QSem' under the 'parallelSemaphore' label. Claiming it +-- with 'waitQSem' limits you against the same pool, but doesn't switch the timer profile, and +-- isn't re-entrant the way 'withParallelLane' is: don't do it underneath something that already +-- holds a lane, or you'll wait for a lane only you can release. parallelN :: ( MonadUnliftIO m, HasBaseContext context - ) => Int -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () + ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( @@ -89,7 +103,7 @@ parallelN' :: ( => NodeOptions -- | Number of lanes -> Int - -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN' nodeOptions n = parallelN'' nodeOptions (pure n) @@ -99,7 +113,7 @@ parallelNFromArgs :: forall context a m. ( ) -- | Callback to extract the number of lanes => (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions @@ -110,7 +124,7 @@ parallelNFromArgs' :: forall context a m. ( => NodeOptions -- | Callback to extract the number of lanes -> (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions (getParallelism <$> getContext commandLineOptions) @@ -120,17 +134,25 @@ parallelN'' :: ( ) => NodeOptions -> ExampleT context m Int - -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN'' nodeOptions getLanes children = introduce "Introduce parallel lanes" parallelLanes (ParallelLanes <$> getLanes) (const $ return ()) $ - parallel' nodeOptions $ - aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children + -- Hand out the pool's semaphore under the old label, so specs can still claim the bound + -- directly. They just don't get the lane's timer profile if they do. + introduce "Introduce parallel semaphore" parallelSemaphore getPoolSemaphore (const $ return ()) $ + parallel' nodeOptions $ + aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children where -- Don't time this node: it starts before we have a lane, so its frame would have to go in a -- profile of its own, which is exactly the clutter the lanes are meant to avoid. laneNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False } + getPoolSemaphore = asks (baseContextLanePool . getBaseContext) >>= \case + Just pool -> pure (lanePoolSem pool) + -- Can't happen: the introduce above always installs a pool. + Nothing -> getContext parallelLanes >>= \(ParallelLanes n) -> liftIO (newQSem (max 1 n)) + -- | Claim one of the lanes introduced by 'parallelN', run the given action, and release it. Blocks -- until a lane is free. -- @@ -155,12 +177,17 @@ withParallelLane action = do action claimLane :: (MonadIO m) => LanePool -> m Int -claimLane (LanePool {lanePoolFree}) = atomically $ readTVar lanePoolFree >>= \case - [] -> retry - (lane:rest) -> writeTVar lanePoolFree rest >> return lane +claimLane (LanePool {lanePoolSem, lanePoolFree}) = liftIO $ do + waitQSem lanePoolSem + flip onException (signalQSem lanePoolSem) $ atomically $ readTVar lanePoolFree >>= \case + -- Can't happen: the semaphore already limits us to the number of lanes. + [] -> retry + (lane:rest) -> writeTVar lanePoolFree rest >> return lane releaseLane :: (MonadIO m) => LanePool -> Int -> m () -releaseLane (LanePool {lanePoolFree}) lane = atomically $ modifyTVar' lanePoolFree (lane :) +releaseLane (LanePool {lanePoolSem, lanePoolFree}) lane = liftIO $ do + atomically $ modifyTVar' lanePoolFree (lane :) + signalQSem lanePoolSem laneProfileName :: LanePool -> Int -> T.Text laneProfileName (LanePool {lanePoolProfileNames}) lane = lanePoolProfileNames !! lane diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index 7f6edb7b..4634fc91 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -10,6 +10,7 @@ module Test.Sandwich.Types.RunTree where import Control.Concurrent.Async +import Control.Concurrent.QSem import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.IO.Class @@ -181,7 +182,12 @@ newtype ParallelLanes = ParallelLanes Int -- | A pool of lanes. A lane is held by one part of the tree at a time, and carries a test timer -- profile name, so everything that runs in it shares a profile. data LanePool = LanePool { - lanePoolFree :: TVar [Int] + -- | The bound itself. Also handed out under the + -- 'Test.Sandwich.ParallelN.parallelSemaphore' label, so that code claiming the semaphore + -- directly is limited by the same thing as code using + -- 'Test.Sandwich.ParallelN.withParallelLane'. + lanePoolSem :: QSem + , lanePoolFree :: TVar [Int] , lanePoolProfileNames :: [T.Text] } From f662fb473312225fb9609ff201ff53b5c5a312aa Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 04:42:56 -0700 Subject: [PATCH 05/15] paralleln: drop parallelNWithLanes and the per-node parallelism limit --- sandwich/CHANGELOG.md | 2 - .../src/Test/Sandwich/Internal/Running.hs | 1 - .../Test/Sandwich/Interpreters/StartTree.hs | 45 +++------- sandwich/src/Test/Sandwich/ParallelN.hs | 83 ------------------- sandwich/src/Test/Sandwich/Types/RunTree.hs | 9 -- 5 files changed, 11 insertions(+), 129 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 6a1a6a40..2ae1a39c 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -13,8 +13,6 @@ specs that are polymorphic in their context. * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already have. -* Add `parallelNWithLanes`, which limits a single parallel node to N children at a time (setup - included) rather than bounding the subtree. * Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 2680e54f..059b9d34 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -123,7 +123,6 @@ baseContextFromOptions options@(Options {..}) = do , baseContextTestTimerProfile = defaultProfileName , baseContextTestTimer = testTimer , baseContextRunId = runId - , baseContextParallelismLimit = Nothing , baseContextLanePool = Nothing , baseContextCurrentLane = Nothing } diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 48a38fa3..12f1dc79 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -10,7 +10,6 @@ module Test.Sandwich.Interpreters.StartTree ( import Control.Concurrent.MVar import Control.Concurrent.QSem -import Control.Concurrent.STM (retry) import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class @@ -64,8 +63,6 @@ applyMagicIntroduce :: (HasBaseContext context, Typeable intro) => RunNodeCommon applyMagicIntroduce (RunNodeCommonWithStatus {runTreeId}) intro ctx | Just (TestTimerProfile t) <- cast intro = pure $ modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - | Just (ParallelismLimit n) <- cast intro = - pure $ modifyBaseContext ctx (\bc -> bc { baseContextParallelismLimit = Just n }) | Just (ParallelLanes n) <- cast intro = do let numLanes = max 1 n sem <- newQSem numLanes @@ -385,34 +382,15 @@ runNodesSequentially children ctx = forM (L.filter (shouldRunChild ctx) children) $ \child -> startTree child ctx >>= wait --- | Run a list of children concurrently, cancelling everything on async exception. --- If a 'ParallelismLimit' was introduced above us, run at most that many children at a time. +-- | Run a list of children concurrently, cancelling everything on async exception runNodesConcurrently :: forall context. HasBaseContext context => RunNodeCommon -> [RunNode context] -> context -> IO [Result] runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) children ctx = - flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ - case baseContextParallelismLimit (getBaseContext ctx) of - Nothing -> do - asyncs <- sequence [startTree child =<< childContext ix - | (child, ix) <- L.zip runnableChildren [0..]] - -- If we stop waiting early because one child threw, take the others down with us; - -- the handler above only fires for async exceptions. - mapM wait asyncs `onException` mapM_ cancel asyncs - Just n -> do - -- Every child gets one of the n lanes, claimed just before it starts and released once - -- it's finished. Since a lane is held for the entire lifetime of a child, the children - -- sharing a lane don't overlap, so they can also share a test timer profile. - lanes <- newTVarIO [0 .. (max 1 n) - 1] - let claimLane = atomically $ readTVar lanes >>= \case - [] -> retry - (lane:rest) -> writeTVar lanes rest >> return lane - let releaseLane lane = atomically $ modifyTVar' lanes (lane :) - - forConcurrently runnableChildren $ \child -> - bracket claimLane releaseLane $ \lane -> do - a <- startTree child =<< childContext lane - -- If we get killed while waiting (because a sibling threw), take the child with us, - -- so we don't release the lane while it's still running. - wait a `onException` cancel a + flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ do + asyncs <- sequence [startTree child =<< childContext ix + | (child, ix) <- L.zip runnableChildren [0..]] + -- If we stop waiting early because one child threw, take the others down with us; + -- the handler above only fires for async exceptions. + mapM wait asyncs `onException` mapM_ cancel asyncs where runnableChildren = L.filter (shouldRunChild ctx) children @@ -420,11 +398,11 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num -- Give each child its own test timer profile, since they can't share one without messing up - -- the nesting of the profile's frames. Also clear the parallelism limit, since we've consumed it. + -- the nesting of the profile's frames. -- - -- Each child gets a fresh cell for the lane it's holding. If we're already inside a lane, the - -- children inherit it (so they don't try to claim a second one and deadlock), but with their - -- own suffix, since they run concurrently and so can't share a profile either. + -- Each child also gets a fresh cell for the lane it's holding. If we're already inside a lane, + -- the children inherit it (so they don't try to claim a second one and deadlock), but with + -- their own suffix, since they run concurrently and so can't share a profile either. childContext :: Int -> IO context childContext n = do parentLane <- case baseContextCurrentLane (getBaseContext ctx) of @@ -433,7 +411,6 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre currentLane <- newTVarIO (bumpProfile n <$> parentLane) return $ modifyBaseContext ctx $ \bc -> bc { baseContextTestTimerProfile = baseContextTestTimerProfile bc <> suffix n - , baseContextParallelismLimit = Nothing , baseContextCurrentLane = Just currentLane } diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index bdc3cd52..8791bb3d 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -7,7 +7,6 @@ -- | Wrappers around 'parallel' for limiting the threads using a semaphore. module Test.Sandwich.ParallelN ( - -- * Limiting with lanes shared by the whole subtree parallelN , parallelN' @@ -16,13 +15,6 @@ module Test.Sandwich.ParallelN ( , withParallelLane - -- * Limiting a single parallel node - , parallelNWithLanes - , parallelNWithLanes' - - , parallelNWithLanesFromArgs - , parallelNWithLanesFromArgs' - , defaultParallelNodeOptions -- * Types @@ -32,10 +24,6 @@ module Test.Sandwich.ParallelN ( , parallelLanes , HasParallelLanes , ParallelLanes(..) - - , parallelismLimit - , HasParallelismLimit - , ParallelismLimit(..) ) where import Control.Concurrent.QSem @@ -65,11 +53,6 @@ parallelLanes = Label type HasParallelLanes context = HasLabel context "parallelLanes" ParallelLanes -parallelismLimit :: Label "parallelismLimit" ParallelismLimit -parallelismLimit = Label - -type HasParallelismLimit context = HasLabel context "parallelismLimit" ParallelismLimit - defaultParallelNodeOptions :: NodeOptions defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } @@ -191,69 +174,3 @@ releaseLane (LanePool {lanePoolSem, lanePoolFree}) lane = liftIO $ do laneProfileName :: LanePool -> Int -> T.Text laneProfileName (LanePool {lanePoolProfileNames}) lane = lanePoolProfileNames !! lane - --- | Wrapper around 'parallel' which runs at most N of its own children at a time. Each child runs --- in one of N lanes, claimed just before it starts and released once it's finished, and the --- children sharing a lane share a test timer profile. So you get N profiles rather than one per --- child, which is much easier to read in the speedscope viewer. --- --- Note that this bounds the children of this node only, which is a different thing from what --- 'parallelN' bounds: --- --- * Setup nodes inside a child count against the limit, since a lane is held for the child's --- whole lifetime. --- --- * 'parallel' nodes nested below a child are /not/ bounded. If your tree is assembled from --- nested parallel nodes (for example by 'Test.Sandwich.TH.getSpecFromFolder' with a parallel --- combiner), use 'parallelN' instead, or the limit will only apply to the top level. -parallelNWithLanes :: ( - Monad m - ) => Int -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () -> SpecFree context m () -parallelNWithLanes = parallelNWithLanes' defaultParallelNodeOptions - -parallelNWithLanes' :: ( - Monad m - ) - -- | Node options - => NodeOptions - -- | Number of lanes - -> Int - -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () - -> SpecFree context m () -parallelNWithLanes' nodeOptions n = parallelNWithLanes'' nodeOptions (pure n) - --- | Same as 'parallelNWithLanes', but extracts the number of lanes from the command line options. -parallelNWithLanesFromArgs :: forall context a m. ( - Monad m, HasCommandLineOptions context a - ) - -- | Callback to extract the number of lanes - => (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () - -> SpecFree context m () -parallelNWithLanesFromArgs = parallelNWithLanesFromArgs' @context @a defaultParallelNodeOptions - -parallelNWithLanesFromArgs' :: forall context a m. ( - Monad m, HasCommandLineOptions context a - ) - -- | Node options - => NodeOptions - -- | Callback to extract the number of lanes - -> (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () - -> SpecFree context m () -parallelNWithLanesFromArgs' nodeOptions getParallelism = - parallelNWithLanes'' nodeOptions (getParallelism <$> getContext commandLineOptions) - -parallelNWithLanes'' :: ( - Monad m - ) - => NodeOptions - -> ExampleT context m Int - -> SpecFree (LabelValue "parallelismLimit" ParallelismLimit :> context) m () - -> SpecFree context m () -parallelNWithLanes'' nodeOptions getLimit children = - -- Introducing a 'ParallelismLimit' is picked up by the 'parallel' node just below, which uses it - -- to run at most N children at a time (and to share test timer profiles between them). The node - -- clears it for its own children, so a nested 'parallel' doesn't claim it a second time. - introduce "Introduce parallelism limit" parallelismLimit (ParallelismLimit <$> getLimit) (const $ return ()) $ - parallel' nodeOptions children diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index 4634fc91..7bad7000 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -157,10 +157,6 @@ data BaseContext = BaseContext { , baseContextTestTimerProfile :: T.Text , baseContextTestTimer :: TestTimer , baseContextRunId :: T.Text - -- | Limit on the number of children the next 'parallel' node should run at - -- once. Set by introducing a 'ParallelismLimit', and consumed (and cleared) - -- by the next 'Test.Sandwich.Types.Spec.Parallel'' node below. - , baseContextParallelismLimit :: Maybe Int -- | Lanes shared by everything below this point, claimed with -- 'Test.Sandwich.ParallelN.withParallelLane'. Set by introducing 'ParallelLanes'. , baseContextLanePool :: Maybe LanePool @@ -169,11 +165,6 @@ data BaseContext = BaseContext { , baseContextCurrentLane :: Maybe (TVar (Maybe LaneState)) } --- | Introduce this value to limit the number of children the next 'parallel' --- node runs at once. See 'Test.Sandwich.ParallelN.parallelNWithLanes'. -newtype ParallelismLimit = ParallelismLimit Int - deriving (Show, Eq) - -- | Introduce this value to make a pool of N lanes available to the spec tree below, to be -- claimed with 'Test.Sandwich.ParallelN.withParallelLane'. See 'Test.Sandwich.ParallelN.parallelN'. newtype ParallelLanes = ParallelLanes Int From 907faa90b2b36753966875eb1b32c40bdbd3e069 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 16:46:30 -0700 Subject: [PATCH 06/15] paralleln: move the lane pool out of the core and into ParallelN --- sandwich/CHANGELOG.md | 5 + .../src/Test/Sandwich/Internal/Running.hs | 6 +- .../Test/Sandwich/Interpreters/StartTree.hs | 49 ++--- sandwich/src/Test/Sandwich/ParallelN.hs | 201 ++++++++++++------ sandwich/src/Test/Sandwich/TestTimer.hs | 47 ++++ sandwich/src/Test/Sandwich/Types/RunTree.hs | 43 +--- sandwich/src/Test/Sandwich/Types/TestTimer.hs | 18 ++ 7 files changed, 235 insertions(+), 134 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 2ae1a39c..b9f48ccc 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -13,6 +13,11 @@ specs that are polymorphic in their context. * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already have. +* Add `withParallelLanes`/`withParallelLanesFromArgs` to introduce a lane pool over a spec tree you + can't wrap with `parallelN`, plus `takeParallelLane` to claim a lane for a whole spec (shaped for + `getSpecIndividualSpecHooks`) and `withParallelLane` to claim one inside a handler. +* Add `withTimingLane`, `inTimingLane` and `newTimingLaneSource` to `Test.Sandwich.TestTimer`, for + switching the test timer profile of a whole subtree from an `around` handler. * Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 059b9d34..3ded3e2c 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -114,6 +114,9 @@ baseContextFromOptions options@(Options {..}) = do let errorSymlinksDir = ( "errors") <$> runRoot whenJust errorSymlinksDir $ createDirectoryIfMissing True + + currentTimingLane <- newTVarIO Nothing + return $ BaseContext { baseContextPath = mempty , baseContextOptions = options @@ -123,8 +126,7 @@ baseContextFromOptions options@(Options {..}) = do , baseContextTestTimerProfile = defaultProfileName , baseContextTestTimer = testTimer , baseContextRunId = runId - , baseContextLanePool = Nothing - , baseContextCurrentLane = Nothing + , baseContextCurrentTimingLane = currentTimingLane } diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 12f1dc79..7df48b0d 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -9,7 +9,6 @@ module Test.Sandwich.Interpreters.StartTree ( import Control.Concurrent.MVar -import Control.Concurrent.QSem import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class @@ -56,28 +55,6 @@ baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseCon baseContextFromCommon (RunNodeCommonWithStatus {..}) bc@(BaseContext {}) = bc { baseContextPath = runTreeFolder } --- | Special hack to modify parts of the 'BaseContext' via an introduce, without --- needing to track them everywhere. It would be better to track these at the --- type level. -applyMagicIntroduce :: (HasBaseContext context, Typeable intro) => RunNodeCommonWithStatus s l t -> intro -> context -> IO context -applyMagicIntroduce (RunNodeCommonWithStatus {runTreeId}) intro ctx - | Just (TestTimerProfile t) <- cast intro = - pure $ modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - | Just (ParallelLanes n) <- cast intro = do - let numLanes = max 1 n - sem <- newQSem numLanes - free <- newTVarIO [0 .. numLanes - 1] - baseProfile <- currentTestTimerProfile (getBaseContext ctx) - let names = [baseProfile <> [i|-lane-#{runTreeId}-#{leftPadWithZerosTo numLanes lane}|] - | lane <- [0 .. numLanes - 1]] - pure $ modifyBaseContext ctx (\bc -> bc { baseContextLanePool = Just (LanePool sem free names) }) - | otherwise = pure ctx - --- | Pad a number with zeros so that all numbers less than the given total have the same width. -leftPadWithZerosTo :: Int -> Int -> String -leftPadWithZerosTo total num = - L.replicate (L.length (show (total - 1)) - L.length (show num)) '0' <> show num - startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result) startTree node@(RunNodeBefore {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon @@ -156,7 +133,12 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do -- TODO: add note about failure in allocation markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason)) Right intro -> do - ctxFinal <- applyMagicIntroduce runNodeCommon intro ctx + -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere. + -- It would be better to track the profile at the type level + let ctxFinal = case cast intro of + Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) + Nothing -> ctx + void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) ) readIORef result @@ -400,25 +382,24 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre -- Give each child its own test timer profile, since they can't share one without messing up -- the nesting of the profile's frames. -- - -- Each child also gets a fresh cell for the lane it's holding. If we're already inside a lane, - -- the children inherit it (so they don't try to claim a second one and deadlock), but with - -- their own suffix, since they run concurrently and so can't share a profile either. + -- Each child also gets its own cell for the timing lanes it holds. If we're already inside a + -- lane, the children inherit it (so a claim from the same source knows not to take a second + -- one and deadlock), but with their own suffix, since they run concurrently and so can't share + -- a profile either. childContext :: Int -> IO context childContext n = do - parentLane <- case baseContextCurrentLane (getBaseContext ctx) of - Nothing -> pure Nothing - Just v -> readTVarIO v - currentLane <- newTVarIO (bumpProfile n <$> parentLane) + parentLane <- readTVarIO (baseContextCurrentTimingLane (getBaseContext ctx)) + currentTimingLane <- newTVarIO (bumpProfile n <$> parentLane) return $ modifyBaseContext ctx $ \bc -> bc { baseContextTestTimerProfile = baseContextTestTimerProfile bc <> suffix n - , baseContextCurrentLane = Just currentLane + , baseContextCurrentTimingLane = currentTimingLane } suffix :: Int -> T.Text suffix n = [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] - bumpProfile :: Int -> LaneState -> LaneState - bumpProfile n ls = ls { laneStateProfile = laneStateProfile ls <> suffix n } + bumpProfile :: Int -> TimingLaneState -> TimingLaneState + bumpProfile n ls = ls { timingLaneProfile = timingLaneProfile ls <> suffix n } markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () markAllChildrenWithResult children baseContext status = do diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 8791bb3d..cb40433e 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -4,26 +4,32 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Wrappers around 'parallel' for limiting the threads using a semaphore. +-- | Wrappers around 'parallel' for limiting how much runs at once. module Test.Sandwich.ParallelN ( + -- * Limiting a parallel node parallelN , parallelN' , parallelNFromArgs , parallelNFromArgs' + -- * Limiting a spec tree you can't wrap directly + , withParallelLanes + , withParallelLanesFromArgs + + , takeParallelLane , withParallelLane , defaultParallelNodeOptions -- * Types - , parallelSemaphore - , HasParallelSemaphore - + , ParallelLanes , parallelLanes , HasParallelLanes - , ParallelLanes(..) + + , parallelSemaphore + , HasParallelSemaphore ) where import Control.Concurrent.QSem @@ -32,51 +38,76 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader +import qualified Data.List as L +import Data.String.Interpolate import qualified Data.Text as T import Test.Sandwich.Contexts +import Test.Sandwich.TestTimer import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec +import Test.Sandwich.Types.TestTimer import UnliftIO.Exception import UnliftIO.STM -- * Types -parallelSemaphore :: Label "parallelSemaphore" QSem -parallelSemaphore = Label - -type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem +-- | A pool of lanes, introduced by 'parallelN' or 'withParallelLanes'. A lane is held by one part +-- of the tree at a time, and carries a test timer profile name, so everything running in it shares +-- a profile. +data ParallelLanes = ParallelLanes { + parallelLanesSource :: TimingLaneSource + -- | The bound itself. Also handed out under the 'parallelSemaphore' label, so that code claiming + -- the semaphore directly is limited by the same thing as code using 'withParallelLane'. + , parallelLanesSem :: QSem + , parallelLanesFree :: TVar [Int] + , parallelLanesProfileNames :: [T.Text] + } parallelLanes :: Label "parallelLanes" ParallelLanes parallelLanes = Label type HasParallelLanes context = HasLabel context "parallelLanes" ParallelLanes +parallelSemaphore :: Label "parallelSemaphore" QSem +parallelSemaphore = Label + +type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem + defaultParallelNodeOptions :: NodeOptions defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } +-- | Options for the nodes that only exist to introduce or claim lanes. Timing them would put a +-- frame outside every lane, which forces a test timer profile of its own -- exactly the clutter +-- lanes are meant to avoid. +laneNodeOptions :: NodeOptions +laneNodeOptions = defaultNodeOptions { + nodeOptionsRecordTime = False + , nodeOptionsCreateFolder = False + , nodeOptionsVisibilityThreshold = 125 + } + -- * Functions -- | Wrapper around 'parallel'. Introduces a pool of N lanes and has each test claim one while it -- runs, so no more than N tests run at once. -- -- The pool is shared by the whole subtree, no matter how deeply nested, so nested 'parallel' nodes --- are limited too. Tests in the subtree can claim a lane themselves with 'withParallelLane', which --- is useful when your specs come from somewhere this function can't wrap directly (such as --- 'Test.Sandwich.TH.getSpecFromFolder'): claim it wherever the expensive work starts, and --- everything below that point runs inside the lane. +-- are limited too. -- --- Each lane is also a test timer profile, so the profile stays readable: you get N profiles rather --- than one per test. +-- Each lane is also a test timer profile, so the timing profile stays readable: you get N profiles +-- rather than one per test. -- --- The bound is also available as a plain 'QSem' under the 'parallelSemaphore' label. Claiming it --- with 'waitQSem' limits you against the same pool, but doesn't switch the timer profile, and --- isn't re-entrant the way 'withParallelLane' is: don't do it underneath something that already --- holds a lane, or you'll wait for a lane only you can release. +-- If your specs come from somewhere this can't wrap directly, such as +-- 'Test.Sandwich.TH.getSpecFromFolder', use 'withParallelLanes' and 'takeParallelLane' instead. parallelN :: ( MonadUnliftIO m, HasBaseContext context - ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () + ) + -- | Number of lanes + => Int + -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions parallelN' :: ( @@ -120,57 +151,105 @@ parallelN'' :: ( -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN'' nodeOptions getLanes children = - introduce "Introduce parallel lanes" parallelLanes (ParallelLanes <$> getLanes) (const $ return ()) $ + withParallelLanes'' getLanes $ -- Hand out the pool's semaphore under the old label, so specs can still claim the bound -- directly. They just don't get the lane's timer profile if they do. - introduce "Introduce parallel semaphore" parallelSemaphore getPoolSemaphore (const $ return ()) $ + introduce' laneNodeOptions "Introduce parallel semaphore" parallelSemaphore (parallelLanesSem <$> getContext parallelLanes) (const $ return ()) $ parallel' nodeOptions $ aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children - where - -- Don't time this node: it starts before we have a lane, so its frame would have to go in a - -- profile of its own, which is exactly the clutter the lanes are meant to avoid. - laneNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False } - getPoolSemaphore = asks (baseContextLanePool . getBaseContext) >>= \case - Just pool -> pure (lanePoolSem pool) - -- Can't happen: the introduce above always installs a pool. - Nothing -> getContext parallelLanes >>= \(ParallelLanes n) -> liftIO (newQSem (max 1 n)) +-- | Introduce a pool of N lanes for the spec tree below, to be claimed with 'takeParallelLane' or +-- 'withParallelLane'. Nothing is limited until something claims a lane. +-- +-- Use this when the tests you want to limit aren't in one place you can wrap with 'parallelN' -- +-- for example when they come from 'Test.Sandwich.TH.getSpecFromFolder', where you can pass +-- 'takeParallelLane' as the individual spec hook. +withParallelLanes :: ( + MonadIO m, HasBaseContext context + ) + -- | Number of lanes + => Int + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree context m () +withParallelLanes n = withParallelLanes'' (pure n) + +-- | Same as 'withParallelLanes', but extracts the number of lanes from the command line options. +withParallelLanesFromArgs :: forall context a m. ( + MonadIO m, HasBaseContext context, HasCommandLineOptions context a + ) + -- | Callback to extract the number of lanes + => (CommandLineOptions a -> Int) + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree context m () +withParallelLanesFromArgs getParallelism = + withParallelLanes'' (getParallelism <$> getContext commandLineOptions) + +withParallelLanes'' :: ( + MonadIO m, HasBaseContext context + ) + => ExampleT context m Int + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree context m () +withParallelLanes'' getLanes = + introduce' laneNodeOptions "Introduce parallel lanes" parallelLanes alloc (const $ return ()) + where + alloc = do + numLanes <- max 1 <$> getLanes + source <- newTimingLaneSource + sem <- liftIO $ newQSem numLanes + free <- newTVarIO [0 .. numLanes - 1] + -- Name the lanes after the profile we're in, so lanes introduced inside another lane (or + -- inside one branch of a parallel node) don't collide with ones introduced elsewhere. + baseProfile <- asks getBaseContext >>= currentTestTimerProfile + let names = [baseProfile <> [i|-lane-#{leftPadWithZeros numLanes lane}|] + | lane <- [0 .. numLanes - 1]] + return $ ParallelLanes source sem free names + + leftPadWithZeros :: Int -> Int -> String + leftPadWithZeros total num = + L.replicate (L.length (show (total - 1)) - L.length (show num)) '0' <> show num + +-- | Claim a lane for a whole spec tree. Shaped to be passed as +-- 'Test.Sandwich.TH.getSpecIndividualSpecHooks', so it takes (and ignores) the discovered module's +-- path. +-- +-- Put this above the node you want inside the lane rather than inside it: anything above the claim +-- can't be in the lane, and gets a test timer profile of its own. +takeParallelLane :: ( + MonadUnliftIO m, HasBaseContext context, HasParallelLanes context + ) + -- | Ignored + => FilePath + -> SpecFree context m () + -> SpecFree context m () +takeParallelLane _ = around' laneNodeOptions "Take parallel lane" (withParallelLane . void) --- | Claim one of the lanes introduced by 'parallelN', run the given action, and release it. Blocks --- until a lane is free. +-- | Claim one of the lanes introduced by 'parallelN' or 'withParallelLanes', run the given action, +-- and release it. Blocks until a lane is free. -- -- Everything the action runs, at any depth, is timed under the lane's test timer profile. -- --- This is a no-op if there are no lanes in scope, or if this part of the tree is already holding --- one: claiming a second lane while holding one could deadlock, so nesting is allowed and ignored. -withParallelLane :: (MonadUnliftIO m, HasBaseContextMonad context m) => m a -> m a +-- If this part of the tree is already holding a lane from the same pool, the action just runs: +-- claiming a second one while holding one could deadlock, so nesting is allowed and ignored. +withParallelLane :: ( + MonadUnliftIO m, HasBaseContextMonad context m, HasParallelLanes context + ) => m a -> m a withParallelLane action = do - BaseContext {..} <- asks getBaseContext - case (baseContextLanePool, baseContextCurrentLane) of - (Nothing, _) -> action - -- We're not underneath a parallel node, so there's no profile to switch; just take a lane. - (Just pool, Nothing) -> bracket (claimLane pool) (releaseLane pool) (const action) - (Just pool, Just currentLane) -> readTVarIO currentLane >>= \case - Just (LaneState {laneStateHeldPools}) | lanePoolFree pool `elem` laneStateHeldPools -> action - heldBefore -> bracket (claimLane pool) (releaseLane pool) $ \lane -> do - let held = LaneState (lanePoolFree pool : maybe [] laneStateHeldPools heldBefore) - (laneProfileName pool lane) - bracket_ (atomically $ writeTVar currentLane (Just held)) - (atomically $ writeTVar currentLane heldBefore) - action - -claimLane :: (MonadIO m) => LanePool -> m Int -claimLane (LanePool {lanePoolSem, lanePoolFree}) = liftIO $ do - waitQSem lanePoolSem - flip onException (signalQSem lanePoolSem) $ atomically $ readTVar lanePoolFree >>= \case + pool <- getContext parallelLanes + inTimingLane (parallelLanesSource pool) >>= \case + True -> action + False -> bracket (claimLane pool) (releaseLane pool) $ \lane -> + withTimingLane (parallelLanesSource pool) (parallelLanesProfileNames pool !! lane) action + +claimLane :: (MonadIO m) => ParallelLanes -> m Int +claimLane (ParallelLanes {parallelLanesSem, parallelLanesFree}) = liftIO $ do + waitQSem parallelLanesSem + flip onException (signalQSem parallelLanesSem) $ atomically $ readTVar parallelLanesFree >>= \case -- Can't happen: the semaphore already limits us to the number of lanes. [] -> retry - (lane:rest) -> writeTVar lanePoolFree rest >> return lane - -releaseLane :: (MonadIO m) => LanePool -> Int -> m () -releaseLane (LanePool {lanePoolSem, lanePoolFree}) lane = liftIO $ do - atomically $ modifyTVar' lanePoolFree (lane :) - signalQSem lanePoolSem + (lane:rest) -> writeTVar parallelLanesFree rest >> return lane -laneProfileName :: LanePool -> Int -> T.Text -laneProfileName (LanePool {lanePoolProfileNames}) lane = lanePoolProfileNames !! lane +releaseLane :: (MonadIO m) => ParallelLanes -> Int -> m () +releaseLane (ParallelLanes {parallelLanesSem, parallelLanesFree}) lane = liftIO $ do + atomically $ modifyTVar' parallelLanesFree (lane :) + signalQSem parallelLanesSem diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index 763a4039..832c6553 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -14,6 +14,10 @@ module Test.Sandwich.TestTimer ( , withTimingProfile , withTimingProfile' + , newTimingLaneSource + , withTimingLane + , inTimingLane + , newSpeedScopeTestTimer , finalizeSpeedScopeTestTimer , renderSpeedScopeFile @@ -32,6 +36,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time import Data.Time.Clock.POSIX +import Data.Unique import Lens.Micro import System.Directory import System.FilePath @@ -40,6 +45,7 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util (whenJust) +import UnliftIO.STM import UnliftIO.Concurrent import UnliftIO.Exception @@ -96,6 +102,47 @@ withTimingProfile' :: (Monad m) -> SpecFree context m () withTimingProfile' getName = introduce' timingNodeOptions [i|Switch test timer profile to dynamic value|] testTimerProfile (TestTimerProfile <$> getName) (\_ -> return ()) +-- * Timing lanes + +-- | Make a new source of timing lanes. Anything claiming a lane with 'withTimingLane' should pass +-- the same source, so that nested claims from that source can be detected. +newTimingLaneSource :: MonadIO m => m TimingLaneSource +newTimingLaneSource = TimingLaneSource <$> liftIO newUnique + +-- | Record this action, and everything below it in the test tree, under the given profile. +-- +-- This is how something that hands out lanes (see 'Test.Sandwich.ParallelN.parallelN') gets +-- everything running in a lane to share a profile: nodes read the profile when they start, so +-- unlike 'withTimingProfile' this works from an 'around' handler, without changing the type of the +-- spec underneath. +-- +-- Concurrent branches of the tree never share the profile set here; a 'Test.Sandwich.parallel' +-- node below gives each of its children a suffixed profile of its own, so their frames can't +-- interleave. +withTimingLane :: (MonadUnliftIO m, HasBaseContextMonad context m) + -- | Who's handing out the lane + => TimingLaneSource + -- | Profile name for the lane + -> ProfileName + -> m a + -> m a +withTimingLane source profileName action = do + BaseContext {baseContextCurrentTimingLane} <- asks getBaseContext + previous <- readTVarIO baseContextCurrentTimingLane + let held = TimingLaneState (source : maybe [] timingLaneSources previous) profileName + bracket_ (atomically $ writeTVar baseContextCurrentTimingLane (Just held)) + (atomically $ writeTVar baseContextCurrentTimingLane previous) + action + +-- | Whether this branch of the tree is already inside a lane from the given source. Claiming a +-- second lane from the same source would deadlock. +inTimingLane :: (MonadIO m, HasBaseContextMonad context m) => TimingLaneSource -> m Bool +inTimingLane source = do + BaseContext {baseContextCurrentTimingLane} <- asks getBaseContext + readTVarIO baseContextCurrentTimingLane >>= \case + Just (TimingLaneState {timingLaneSources}) -> pure (source `elem` timingLaneSources) + Nothing -> pure False + -- * Core timingNodeOptions :: NodeOptions diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index 7bad7000..adf38148 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -10,7 +10,6 @@ module Test.Sandwich.Types.RunTree where import Control.Concurrent.Async -import Control.Concurrent.QSem import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.IO.Class @@ -157,47 +156,17 @@ data BaseContext = BaseContext { , baseContextTestTimerProfile :: T.Text , baseContextTestTimer :: TestTimer , baseContextRunId :: T.Text - -- | Lanes shared by everything below this point, claimed with - -- 'Test.Sandwich.ParallelN.withParallelLane'. Set by introducing 'ParallelLanes'. - , baseContextLanePool :: Maybe LanePool - -- | The lanes held on this branch of the tree, if any. Concurrent branches always get their - -- own cell, so only one thread writes this at a time. - , baseContextCurrentLane :: Maybe (TVar (Maybe LaneState)) - } - --- | Introduce this value to make a pool of N lanes available to the spec tree below, to be --- claimed with 'Test.Sandwich.ParallelN.withParallelLane'. See 'Test.Sandwich.ParallelN.parallelN'. -newtype ParallelLanes = ParallelLanes Int - deriving (Show, Eq) - --- | A pool of lanes. A lane is held by one part of the tree at a time, and carries a test timer --- profile name, so everything that runs in it shares a profile. -data LanePool = LanePool { - -- | The bound itself. Also handed out under the - -- 'Test.Sandwich.ParallelN.parallelSemaphore' label, so that code claiming the semaphore - -- directly is limited by the same thing as code using - -- 'Test.Sandwich.ParallelN.withParallelLane'. - lanePoolSem :: QSem - , lanePoolFree :: TVar [Int] - , lanePoolProfileNames :: [T.Text] - } - --- | The lanes held on one branch of the tree. -data LaneState = LaneState { - -- | The pools we're already holding a lane from. Claiming a second lane from the same pool - -- would deadlock, since we'd be waiting for a lane that only we can release. - laneStateHeldPools :: [TVar [Int]] - -- | The test timer profile for the innermost lane we hold. - , laneStateProfile :: T.Text + -- | The timing lanes held on this branch of the tree. Branches that run concurrently always get + -- their own cell. See 'Test.Sandwich.TestTimer.withTimingLane'. + , baseContextCurrentTimingLane :: TVar (Maybe TimingLaneState) } -- | The test timer profile to record frames under right now: the lane's profile if this branch is -- holding one, and the node's own profile otherwise. currentTestTimerProfile :: MonadIO m => BaseContext -> m T.Text -currentTestTimerProfile (BaseContext {..}) = case baseContextCurrentLane of - Nothing -> pure baseContextTestTimerProfile - Just v -> liftIO (readTVarIO v) >>= \case - Just (LaneState {laneStateProfile}) -> pure laneStateProfile +currentTestTimerProfile (BaseContext {..}) = + liftIO (readTVarIO baseContextCurrentTimingLane) >>= \case + Just (TimingLaneState {timingLaneProfile}) -> pure timingLaneProfile Nothing -> pure baseContextTestTimerProfile -- | Has-* class for asserting a 'BaseContext' is available. diff --git a/sandwich/src/Test/Sandwich/Types/TestTimer.hs b/sandwich/src/Test/Sandwich/Types/TestTimer.hs index 1f912292..7cc21f4a 100644 --- a/sandwich/src/Test/Sandwich/Types/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/Types/TestTimer.hs @@ -14,6 +14,7 @@ import qualified Data.List as L import Data.Sequence import qualified Data.Text as T import Data.Time.Clock.POSIX +import Data.Unique import Lens.Micro.TH import System.IO import Test.Sandwich.Types.Spec @@ -136,3 +137,20 @@ testTimerProfile :: Label "testTimerProfile" TestTimerProfile testTimerProfile = Label :: Label "testTimerProfile" TestTimerProfile newtype TestTimerProfile = TestTimerProfile T.Text + +-- * Timing lanes + +-- | Identifies whoever is handing out timing lanes, so that a claim from the same source can tell +-- it's already inside one of its own lanes. See 'Test.Sandwich.TestTimer.newTimingLaneSource'. +newtype TimingLaneSource = TimingLaneSource Unique + deriving (Eq) + +-- | The timing lanes held on one branch of the test tree. Branches that run concurrently always +-- get their own copy of this, so only one thread writes it at a time. +data TimingLaneState = TimingLaneState { + -- | The sources we're already holding a lane from. Claiming a second lane from the same source + -- would deadlock, since we'd be waiting for a lane only we can release. + timingLaneSources :: [TimingLaneSource] + -- | The profile to record frames under while we hold these lanes. + , timingLaneProfile :: T.Text + } From af66f14837ee8714053a53cb9caeb4f481ae2887 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 17:23:04 -0700 Subject: [PATCH 07/15] sandwich: export the timing lane functions from Test.Sandwich --- sandwich/src/Test/Sandwich.hs | 9 +++++++++ sandwich/src/Test/Sandwich/ParallelN.hs | 1 - sandwich/src/Test/Sandwich/TestTimer.hs | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index 765269f5..31a6bbe4 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/sandwich/src/Test/Sandwich.hs @@ -56,6 +56,15 @@ module Test.Sandwich ( , withTimingProfile , withTimingProfile' + -- ** Timing lanes + -- + -- | For giving a whole subtree a different profile from an 'around' handler. Used by + -- 'withParallelLane'; you only need these if you're building something like it. + , TimingLaneSource + , newTimingLaneSource + , withTimingLane + , inTimingLane + -- * Managed async -- -- | If you want to run asyncs within your tests, we can help keep track of diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index cb40433e..23430c00 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -46,7 +46,6 @@ import Test.Sandwich.TestTimer import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec -import Test.Sandwich.Types.TestTimer import UnliftIO.Exception import UnliftIO.STM diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index 832c6553..03e4e070 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -14,6 +14,7 @@ module Test.Sandwich.TestTimer ( , withTimingProfile , withTimingProfile' + , TimingLaneSource , newTimingLaneSource , withTimingLane , inTimingLane From eb6f4086614f9db97c959e59cfda176da6aa8de7 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 17:28:16 -0700 Subject: [PATCH 08/15] paralleln: fold the semaphore into ParallelLanes --- sandwich/CHANGELOG.md | 10 ++++----- sandwich/src/Test/Sandwich/ParallelN.hs | 29 ++++++++----------------- 2 files changed, 14 insertions(+), 25 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index b9f48ccc..7fa96ef3 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -6,11 +6,11 @@ * `parallelN` now limits with a pool of lanes rather than a semaphore. The bound is still global over the whole subtree, including nested `parallel` nodes, but each lane is also a test timer profile, so you get N profiles instead of one per test. - * The `parallelSemaphore` label still hands out a `QSem`, and it's the pool's own semaphore, so - claiming it directly is bounded by the same thing. To also get the lane's timer profile (and - re-entrancy, for hooks that apply at several depths), claim with `withParallelLane` instead. - * `parallelN`'s child spec type has an extra `parallelLanes` label in it, which is inferred for - specs that are polymorphic in their context. + * Breaking: the `parallelSemaphore` label and `HasParallelSemaphore` are gone; the semaphore now + lives inside the pool. Claim with `withParallelLane` instead of taking the `QSem` yourself. + It's also re-entrant, so hooks that apply at several depths only claim once. + * `parallelN`'s child spec type now has a `parallelLanes` label rather than a `parallelSemaphore` + one; either way it's inferred for specs that are polymorphic in their context. * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already have. * Add `withParallelLanes`/`withParallelLanesFromArgs` to introduce a lane pool over a spec tree you diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 23430c00..6760d333 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -27,9 +27,6 @@ module Test.Sandwich.ParallelN ( , ParallelLanes , parallelLanes , HasParallelLanes - - , parallelSemaphore - , HasParallelSemaphore ) where import Control.Concurrent.QSem @@ -57,8 +54,8 @@ import UnliftIO.STM -- a profile. data ParallelLanes = ParallelLanes { parallelLanesSource :: TimingLaneSource - -- | The bound itself. Also handed out under the 'parallelSemaphore' label, so that code claiming - -- the semaphore directly is limited by the same thing as code using 'withParallelLane'. + -- | The bound itself. Handing lanes out in wait order is nicer than having everyone race for a + -- free slot, so we gate on this before touching the free list. , parallelLanesSem :: QSem , parallelLanesFree :: TVar [Int] , parallelLanesProfileNames :: [T.Text] @@ -69,11 +66,6 @@ parallelLanes = Label type HasParallelLanes context = HasLabel context "parallelLanes" ParallelLanes -parallelSemaphore :: Label "parallelSemaphore" QSem -parallelSemaphore = Label - -type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem - defaultParallelNodeOptions :: NodeOptions defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } @@ -105,7 +97,7 @@ parallelN :: ( ) -- | Number of lanes => Int - -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions @@ -116,7 +108,7 @@ parallelN' :: ( => NodeOptions -- | Number of lanes -> Int - -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN' nodeOptions n = parallelN'' nodeOptions (pure n) @@ -126,7 +118,7 @@ parallelNFromArgs :: forall context a m. ( ) -- | Callback to extract the number of lanes => (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions @@ -137,7 +129,7 @@ parallelNFromArgs' :: forall context a m. ( => NodeOptions -- | Callback to extract the number of lanes -> (CommandLineOptions a -> Int) - -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions (getParallelism <$> getContext commandLineOptions) @@ -147,15 +139,12 @@ parallelN'' :: ( ) => NodeOptions -> ExampleT context m Int - -> SpecFree (LabelValue "parallelSemaphore" QSem :> LabelValue "parallelLanes" ParallelLanes :> context) m () + -> SpecFree (LabelValue "parallelLanes" ParallelLanes :> context) m () -> SpecFree context m () parallelN'' nodeOptions getLanes children = withParallelLanes'' getLanes $ - -- Hand out the pool's semaphore under the old label, so specs can still claim the bound - -- directly. They just don't get the lane's timer profile if they do. - introduce' laneNodeOptions "Introduce parallel semaphore" parallelSemaphore (parallelLanesSem <$> getContext parallelLanes) (const $ return ()) $ - parallel' nodeOptions $ - aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children + parallel' nodeOptions $ + aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children -- | Introduce a pool of N lanes for the spec tree below, to be claimed with 'takeParallelLane' or -- 'withParallelLane'. Nothing is limited until something claims a lane. From e41e25c930f07f5148a3f688246daee7ab390fa5 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 17:35:13 -0700 Subject: [PATCH 09/15] paralleln: tighten up the haddocks --- .../Test/Sandwich/Interpreters/StartTree.hs | 11 +-- sandwich/src/Test/Sandwich/ParallelN.hs | 78 ++++++++----------- sandwich/src/Test/Sandwich/TestTimer.hs | 19 ++--- sandwich/src/Test/Sandwich/Types/RunTree.hs | 7 +- sandwich/src/Test/Sandwich/Types/TestTimer.hs | 13 ++-- 5 files changed, 52 insertions(+), 76 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 7df48b0d..f571e014 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -379,13 +379,10 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre leftPadWithZeros :: Int -> String leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num - -- Give each child its own test timer profile, since they can't share one without messing up - -- the nesting of the profile's frames. - -- - -- Each child also gets its own cell for the timing lanes it holds. If we're already inside a - -- lane, the children inherit it (so a claim from the same source knows not to take a second - -- one and deadlock), but with their own suffix, since they run concurrently and so can't share - -- a profile either. + -- Give each child its own test timer profile, since sharing one would mess up the nesting of + -- the profile's frames, and its own cell for the timing lanes it holds. Children inherit any + -- lane we're already in (so they don't claim a second one and deadlock), but with their own + -- profile suffix. childContext :: Int -> IO context childContext n = do parentLane <- readTVarIO (baseContextCurrentTimingLane (getBaseContext ctx)) diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index 6760d333..d80e23d6 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -14,12 +14,12 @@ module Test.Sandwich.ParallelN ( , parallelNFromArgs , parallelNFromArgs' - -- * Limiting a spec tree you can't wrap directly + -- * Claiming lanes yourself , withParallelLanes , withParallelLanesFromArgs - , takeParallelLane , withParallelLane + , takeParallelLane , defaultParallelNodeOptions @@ -49,13 +49,11 @@ import UnliftIO.STM -- * Types --- | A pool of lanes, introduced by 'parallelN' or 'withParallelLanes'. A lane is held by one part --- of the tree at a time, and carries a test timer profile name, so everything running in it shares --- a profile. +-- | A pool of lanes. Each lane is held by one part of the tree at a time, and has a test timer +-- profile of its own. data ParallelLanes = ParallelLanes { parallelLanesSource :: TimingLaneSource - -- | The bound itself. Handing lanes out in wait order is nicer than having everyone race for a - -- free slot, so we gate on this before touching the free list. + -- | The bound. Gating on this first hands lanes out in wait order. , parallelLanesSem :: QSem , parallelLanesFree :: TVar [Int] , parallelLanesProfileNames :: [T.Text] @@ -69,9 +67,8 @@ type HasParallelLanes context = HasLabel context "parallelLanes" ParallelLanes defaultParallelNodeOptions :: NodeOptions defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } --- | Options for the nodes that only exist to introduce or claim lanes. Timing them would put a --- frame outside every lane, which forces a test timer profile of its own -- exactly the clutter --- lanes are meant to avoid. +-- Options for nodes that only introduce or claim lanes. Timing them would put a frame outside +-- every lane, forcing a profile of its own. laneNodeOptions :: NodeOptions laneNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False @@ -81,17 +78,13 @@ laneNodeOptions = defaultNodeOptions { -- * Functions --- | Wrapper around 'parallel'. Introduces a pool of N lanes and has each test claim one while it --- runs, so no more than N tests run at once. --- --- The pool is shared by the whole subtree, no matter how deeply nested, so nested 'parallel' nodes --- are limited too. +-- | Wrapper around 'parallel' which limits the parallelism to N tests at a time. -- --- Each lane is also a test timer profile, so the timing profile stays readable: you get N profiles --- rather than one per test. +-- Introduces a pool of N lanes, one of which each test claims while it runs. The pool is shared by +-- the whole subtree, so nested 'parallel' nodes are limited too, and each lane is a test timer +-- profile, so you get N profiles rather than one per test. -- --- If your specs come from somewhere this can't wrap directly, such as --- 'Test.Sandwich.TH.getSpecFromFolder', use 'withParallelLanes' and 'takeParallelLane' instead. +-- To limit specs this can't wrap directly, see 'withParallelLanes'. parallelN :: ( MonadUnliftIO m, HasBaseContext context ) @@ -146,12 +139,11 @@ parallelN'' nodeOptions getLanes children = parallel' nodeOptions $ aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children --- | Introduce a pool of N lanes for the spec tree below, to be claimed with 'takeParallelLane' or --- 'withParallelLane'. Nothing is limited until something claims a lane. +-- | Introduce a pool of N lanes, to be claimed with 'withParallelLane' or 'takeParallelLane'. +-- Nothing is limited until something claims one. -- --- Use this when the tests you want to limit aren't in one place you can wrap with 'parallelN' -- --- for example when they come from 'Test.Sandwich.TH.getSpecFromFolder', where you can pass --- 'takeParallelLane' as the individual spec hook. +-- Use this when the tests to limit aren't in one place you can wrap with 'parallelN', such as ones +-- from 'Test.Sandwich.TH.getSpecFromFolder'. withParallelLanes :: ( MonadIO m, HasBaseContext context ) @@ -197,28 +189,11 @@ withParallelLanes'' getLanes = leftPadWithZeros total num = L.replicate (L.length (show (total - 1)) - L.length (show num)) '0' <> show num --- | Claim a lane for a whole spec tree. Shaped to be passed as --- 'Test.Sandwich.TH.getSpecIndividualSpecHooks', so it takes (and ignores) the discovered module's --- path. --- --- Put this above the node you want inside the lane rather than inside it: anything above the claim --- can't be in the lane, and gets a test timer profile of its own. -takeParallelLane :: ( - MonadUnliftIO m, HasBaseContext context, HasParallelLanes context - ) - -- | Ignored - => FilePath - -> SpecFree context m () - -> SpecFree context m () -takeParallelLane _ = around' laneNodeOptions "Take parallel lane" (withParallelLane . void) - --- | Claim one of the lanes introduced by 'parallelN' or 'withParallelLanes', run the given action, --- and release it. Blocks until a lane is free. --- --- Everything the action runs, at any depth, is timed under the lane's test timer profile. +-- | Claim a lane, run the action, and release it. Blocks until a lane is free. Everything the +-- action runs, at any depth, is timed under the lane's profile. -- --- If this part of the tree is already holding a lane from the same pool, the action just runs: --- claiming a second one while holding one could deadlock, so nesting is allowed and ignored. +-- A no-op if this part of the tree already holds a lane from the same pool, since claiming a +-- second one could deadlock. withParallelLane :: ( MonadUnliftIO m, HasBaseContextMonad context m, HasParallelLanes context ) => m a -> m a @@ -229,6 +204,19 @@ withParallelLane action = do False -> bracket (claimLane pool) (releaseLane pool) $ \lane -> withTimingLane (parallelLanesSource pool) (parallelLanesProfileNames pool !! lane) action +-- | 'withParallelLane' as a spec node, shaped for +-- 'Test.Sandwich.TH.getSpecIndividualSpecHooks' (hence the ignored 'FilePath'). +-- +-- Put it above the node you want in the lane; anything above the claim gets its own profile. +takeParallelLane :: ( + MonadUnliftIO m, HasBaseContext context, HasParallelLanes context + ) + -- | Ignored + => FilePath + -> SpecFree context m () + -> SpecFree context m () +takeParallelLane _ = around' laneNodeOptions "Take parallel lane" (withParallelLane . void) + claimLane :: (MonadIO m) => ParallelLanes -> m Int claimLane (ParallelLanes {parallelLanesSem, parallelLanesFree}) = liftIO $ do waitQSem parallelLanesSem diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index 03e4e070..c1eb8342 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -105,21 +105,15 @@ withTimingProfile' getName = introduce' timingNodeOptions [i|Switch test timer p -- * Timing lanes --- | Make a new source of timing lanes. Anything claiming a lane with 'withTimingLane' should pass --- the same source, so that nested claims from that source can be detected. +-- | Make a new source of timing lanes. Pass the same one to 'withTimingLane' and 'inTimingLane'. newTimingLaneSource :: MonadIO m => m TimingLaneSource newTimingLaneSource = TimingLaneSource <$> liftIO newUnique --- | Record this action, and everything below it in the test tree, under the given profile. +-- | Record this action, and everything below it in the tree, under the given profile. Unlike +-- 'withTimingProfile' this works from an 'around' handler, without changing the spec's type. -- --- This is how something that hands out lanes (see 'Test.Sandwich.ParallelN.parallelN') gets --- everything running in a lane to share a profile: nodes read the profile when they start, so --- unlike 'withTimingProfile' this works from an 'around' handler, without changing the type of the --- spec underneath. --- --- Concurrent branches of the tree never share the profile set here; a 'Test.Sandwich.parallel' --- node below gives each of its children a suffixed profile of its own, so their frames can't --- interleave. +-- A 'Test.Sandwich.parallel' node below gives each of its children a suffixed profile of their +-- own, so concurrent branches never share one. withTimingLane :: (MonadUnliftIO m, HasBaseContextMonad context m) -- | Who's handing out the lane => TimingLaneSource @@ -135,8 +129,7 @@ withTimingLane source profileName action = do (atomically $ writeTVar baseContextCurrentTimingLane previous) action --- | Whether this branch of the tree is already inside a lane from the given source. Claiming a --- second lane from the same source would deadlock. +-- | Whether this branch of the tree already holds a lane from the given source. inTimingLane :: (MonadIO m, HasBaseContextMonad context m) => TimingLaneSource -> m Bool inTimingLane source = do BaseContext {baseContextCurrentTimingLane} <- asks getBaseContext diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index adf38148..243ff27c 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -156,13 +156,12 @@ data BaseContext = BaseContext { , baseContextTestTimerProfile :: T.Text , baseContextTestTimer :: TestTimer , baseContextRunId :: T.Text - -- | The timing lanes held on this branch of the tree. Branches that run concurrently always get - -- their own cell. See 'Test.Sandwich.TestTimer.withTimingLane'. + -- | The timing lanes held on this branch of the tree. See + -- 'Test.Sandwich.TestTimer.withTimingLane'. , baseContextCurrentTimingLane :: TVar (Maybe TimingLaneState) } --- | The test timer profile to record frames under right now: the lane's profile if this branch is --- holding one, and the node's own profile otherwise. +-- | The profile to record frames under right now: the lane's, if this branch holds one. currentTestTimerProfile :: MonadIO m => BaseContext -> m T.Text currentTestTimerProfile (BaseContext {..}) = liftIO (readTVarIO baseContextCurrentTimingLane) >>= \case diff --git a/sandwich/src/Test/Sandwich/Types/TestTimer.hs b/sandwich/src/Test/Sandwich/Types/TestTimer.hs index 7cc21f4a..4f3a53df 100644 --- a/sandwich/src/Test/Sandwich/Types/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/Types/TestTimer.hs @@ -140,17 +140,16 @@ newtype TestTimerProfile = TestTimerProfile T.Text -- * Timing lanes --- | Identifies whoever is handing out timing lanes, so that a claim from the same source can tell --- it's already inside one of its own lanes. See 'Test.Sandwich.TestTimer.newTimingLaneSource'. +-- | Identifies whoever is handing out timing lanes. See +-- 'Test.Sandwich.TestTimer.newTimingLaneSource'. newtype TimingLaneSource = TimingLaneSource Unique deriving (Eq) --- | The timing lanes held on one branch of the test tree. Branches that run concurrently always --- get their own copy of this, so only one thread writes it at a time. +-- | The timing lanes held on one branch of the test tree. Concurrent branches always get their own +-- copy, so only one thread writes it at a time. data TimingLaneState = TimingLaneState { - -- | The sources we're already holding a lane from. Claiming a second lane from the same source - -- would deadlock, since we'd be waiting for a lane only we can release. + -- | The sources we're holding a lane from. Claiming a second lane from one of these would + -- deadlock, since only we can release it. timingLaneSources :: [TimingLaneSource] - -- | The profile to record frames under while we hold these lanes. , timingLaneProfile :: T.Text } From 80e8a6e88d3a44075694837507e6056932458120 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 17:44:14 -0700 Subject: [PATCH 10/15] sandwich: list the ParallelN exports explicitly so haddock keeps their order --- sandwich/src/Test/Sandwich.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index 31a6bbe4..6d043bcb 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/sandwich/src/Test/Sandwich.hs @@ -46,7 +46,21 @@ module Test.Sandwich ( , aroundEach -- * Parallel nodes - , module Test.Sandwich.ParallelN + , parallelN + , parallelN' + , parallelNFromArgs + , parallelNFromArgs' + , defaultParallelNodeOptions + + -- ** Claiming lanes yourself + , withParallelLanes + , withParallelLanesFromArgs + , withParallelLane + , takeParallelLane + + , ParallelLanes + , parallelLanes + , HasParallelLanes -- * Timing -- From ce2928d782b66ad5503255dffc106d37d06bbc69 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sat, 25 Jul 2026 18:44:17 -0700 Subject: [PATCH 11/15] More on haddocks --- sandwich/src/Test/Sandwich.hs | 2 +- sandwich/src/Test/Sandwich/ParallelN.hs | 15 +++++---------- sandwich/src/Test/Sandwich/TestTimer.hs | 8 ++++---- 3 files changed, 10 insertions(+), 15 deletions(-) diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index 6d043bcb..34178ab4 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/sandwich/src/Test/Sandwich.hs @@ -52,7 +52,7 @@ module Test.Sandwich ( , parallelNFromArgs' , defaultParallelNodeOptions - -- ** Claiming lanes yourself + -- ** Lower-level , withParallelLanes , withParallelLanesFromArgs , withParallelLane diff --git a/sandwich/src/Test/Sandwich/ParallelN.hs b/sandwich/src/Test/Sandwich/ParallelN.hs index d80e23d6..c41d0b00 100644 --- a/sandwich/src/Test/Sandwich/ParallelN.hs +++ b/sandwich/src/Test/Sandwich/ParallelN.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Wrappers around 'parallel' for limiting how much runs at once. +-- | Limiting how much of a test tree runs at once. module Test.Sandwich.ParallelN ( -- * Limiting a parallel node @@ -14,7 +14,7 @@ module Test.Sandwich.ParallelN ( , parallelNFromArgs , parallelNFromArgs' - -- * Claiming lanes yourself + -- * Lower-level , withParallelLanes , withParallelLanesFromArgs @@ -78,13 +78,11 @@ laneNodeOptions = defaultNodeOptions { -- * Functions --- | Wrapper around 'parallel' which limits the parallelism to N tests at a time. +-- | Like 'parallel', but limits the parallelism to N tests at a time. -- -- Introduces a pool of N lanes, one of which each test claims while it runs. The pool is shared by -- the whole subtree, so nested 'parallel' nodes are limited too, and each lane is a test timer -- profile, so you get N profiles rather than one per test. --- --- To limit specs this can't wrap directly, see 'withParallelLanes'. parallelN :: ( MonadUnliftIO m, HasBaseContext context ) @@ -140,7 +138,6 @@ parallelN'' nodeOptions getLanes children = aroundEach' Nothing laneNodeOptions "Take parallel lane" (withParallelLane . void) children -- | Introduce a pool of N lanes, to be claimed with 'withParallelLane' or 'takeParallelLane'. --- Nothing is limited until something claims one. -- -- Use this when the tests to limit aren't in one place you can wrap with 'parallelN', such as ones -- from 'Test.Sandwich.TH.getSpecFromFolder'. @@ -204,10 +201,8 @@ withParallelLane action = do False -> bracket (claimLane pool) (releaseLane pool) $ \lane -> withTimingLane (parallelLanesSource pool) (parallelLanesProfileNames pool !! lane) action --- | 'withParallelLane' as a spec node, shaped for --- 'Test.Sandwich.TH.getSpecIndividualSpecHooks' (hence the ignored 'FilePath'). --- --- Put it above the node you want in the lane; anything above the claim gets its own profile. +-- | 'withParallelLane' as a spec node, designed for use with +-- 'Test.Sandwich.TH.getSpecIndividualSpecHooks'. takeParallelLane :: ( MonadUnliftIO m, HasBaseContext context, HasParallelLanes context ) diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index c1eb8342..d93b4405 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -46,9 +46,9 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util (whenJust) -import UnliftIO.STM import UnliftIO.Concurrent import UnliftIO.Exception +import UnliftIO.STM type EventName = T.Text @@ -171,9 +171,9 @@ finalizeSpeedScopeTestTimer tt@(SpeedScopeTestTimer {..}) = do whenJust contents $ BL.writeFile (testTimerBasePath "speedscope.json") --- | Render the current state of the test timer as a speedscope profile. Any --- frames that are still open are closed off at the current time, so this can be --- called while tests are running. +-- | Render the current state of the test timer as a speedscope profile. Frames +-- that are still open are closed off at the current time, so this can be called +-- while tests are running. renderSpeedScopeFile :: MonadIO m => TestTimer -> m (Maybe BL.ByteString) renderSpeedScopeFile NullTestTimer = return Nothing renderSpeedScopeFile (SpeedScopeTestTimer {..}) = liftIO $ do From f14182108d0fa0e35be318cdfb3d5215b1fb6608 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 26 Jul 2026 03:23:10 -0700 Subject: [PATCH 12/15] Fixups noci --- .../src/Test/Sandwich/Internal/Running.hs | 5 ++-- .../Test/Sandwich/Interpreters/StartTree.hs | 29 +++++++++---------- sandwich/src/Test/Sandwich/TestTimer.hs | 16 +++++----- sandwich/src/Test/Sandwich/Types/RunTree.hs | 12 ++------ sandwich/src/Test/Sandwich/Types/TestTimer.hs | 12 ++++---- 5 files changed, 30 insertions(+), 44 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs index 3ded3e2c..b1c6976d 100644 --- a/sandwich/src/Test/Sandwich/Internal/Running.hs +++ b/sandwich/src/Test/Sandwich/Internal/Running.hs @@ -115,7 +115,7 @@ baseContextFromOptions options@(Options {..}) = do let errorSymlinksDir = ( "errors") <$> runRoot whenJust errorSymlinksDir $ createDirectoryIfMissing True - currentTimingLane <- newTVarIO Nothing + timingProfile <- newTVarIO (TimingProfile defaultProfileName []) return $ BaseContext { baseContextPath = mempty @@ -123,10 +123,9 @@ baseContextFromOptions options@(Options {..}) = do , baseContextRunRoot = runRoot , baseContextErrorSymlinksDir = errorSymlinksDir , baseContextOnlyRunIds = Nothing - , baseContextTestTimerProfile = defaultProfileName + , baseContextTimingProfile = timingProfile , baseContextTestTimer = testTimer , baseContextRunId = runId - , baseContextCurrentTimingLane = currentTimingLane } diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index f571e014..27e6ed74 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -135,9 +135,13 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do Right intro -> do -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere. -- It would be better to track the profile at the type level - let ctxFinal = case cast intro of - Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - Nothing -> ctx + ctxFinal <- case cast intro of + Just (TestTimerProfile t) -> do + -- A fresh cell, so we rename the profile for our children only. + current <- readTVarIO (baseContextTimingProfile (getBaseContext ctx)) + timingProfile <- newTVarIO (current { timingProfileName = t }) + return $ modifyBaseContext ctx (\bc -> bc { baseContextTimingProfile = timingProfile }) + Nothing -> return ctx void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) ) @@ -379,25 +383,18 @@ runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) childre leftPadWithZeros :: Int -> String leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num - -- Give each child its own test timer profile, since sharing one would mess up the nesting of - -- the profile's frames, and its own cell for the timing lanes it holds. Children inherit any - -- lane we're already in (so they don't claim a second one and deadlock), but with their own - -- profile suffix. + -- Give each child its own test timer profile, since sharing one would mess up the nesting of the + -- profile's frames. Children keep any lanes we're already holding, so they don't claim a second + -- one and deadlock. childContext :: Int -> IO context childContext n = do - parentLane <- readTVarIO (baseContextCurrentTimingLane (getBaseContext ctx)) - currentTimingLane <- newTVarIO (bumpProfile n <$> parentLane) - return $ modifyBaseContext ctx $ \bc -> bc { - baseContextTestTimerProfile = baseContextTestTimerProfile bc <> suffix n - , baseContextCurrentTimingLane = currentTimingLane - } + current <- readTVarIO (baseContextTimingProfile (getBaseContext ctx)) + timingProfile <- newTVarIO (current { timingProfileName = timingProfileName current <> suffix n }) + return $ modifyBaseContext ctx $ \bc -> bc { baseContextTimingProfile = timingProfile } suffix :: Int -> T.Text suffix n = [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] - bumpProfile :: Int -> TimingLaneState -> TimingLaneState - bumpProfile n ls = ls { timingLaneProfile = timingLaneProfile ls <> suffix n } - markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () markAllChildrenWithResult children baseContext status = do now <- liftIO getCurrentTime diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index d93b4405..6acf1ab4 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -122,20 +122,18 @@ withTimingLane :: (MonadUnliftIO m, HasBaseContextMonad context m) -> m a -> m a withTimingLane source profileName action = do - BaseContext {baseContextCurrentTimingLane} <- asks getBaseContext - previous <- readTVarIO baseContextCurrentTimingLane - let held = TimingLaneState (source : maybe [] timingLaneSources previous) profileName - bracket_ (atomically $ writeTVar baseContextCurrentTimingLane (Just held)) - (atomically $ writeTVar baseContextCurrentTimingLane previous) + BaseContext {baseContextTimingProfile} <- asks getBaseContext + previous <- readTVarIO baseContextTimingProfile + let held = TimingProfile profileName (source : timingProfileLanes previous) + bracket_ (atomically $ writeTVar baseContextTimingProfile held) + (atomically $ writeTVar baseContextTimingProfile previous) action -- | Whether this branch of the tree already holds a lane from the given source. inTimingLane :: (MonadIO m, HasBaseContextMonad context m) => TimingLaneSource -> m Bool inTimingLane source = do - BaseContext {baseContextCurrentTimingLane} <- asks getBaseContext - readTVarIO baseContextCurrentTimingLane >>= \case - Just (TimingLaneState {timingLaneSources}) -> pure (source `elem` timingLaneSources) - Nothing -> pure False + BaseContext {baseContextTimingProfile} <- asks getBaseContext + (source `elem`) . timingProfileLanes <$> readTVarIO baseContextTimingProfile -- * Core diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index 243ff27c..a61b08b9 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -153,20 +153,14 @@ data BaseContext = BaseContext { , baseContextErrorSymlinksDir :: Maybe FilePath , baseContextOptions :: Options , baseContextOnlyRunIds :: Maybe (S.Set Int) - , baseContextTestTimerProfile :: T.Text + , baseContextTimingProfile :: TVar TimingProfile , baseContextTestTimer :: TestTimer , baseContextRunId :: T.Text - -- | The timing lanes held on this branch of the tree. See - -- 'Test.Sandwich.TestTimer.withTimingLane'. - , baseContextCurrentTimingLane :: TVar (Maybe TimingLaneState) } --- | The profile to record frames under right now: the lane's, if this branch holds one. +-- | The profile to record frames under right now. currentTestTimerProfile :: MonadIO m => BaseContext -> m T.Text -currentTestTimerProfile (BaseContext {..}) = - liftIO (readTVarIO baseContextCurrentTimingLane) >>= \case - Just (TimingLaneState {timingLaneProfile}) -> pure timingLaneProfile - Nothing -> pure baseContextTestTimerProfile +currentTestTimerProfile (BaseContext {..}) = timingProfileName <$> liftIO (readTVarIO baseContextTimingProfile) -- | Has-* class for asserting a 'BaseContext' is available. class HasBaseContext a where diff --git a/sandwich/src/Test/Sandwich/Types/TestTimer.hs b/sandwich/src/Test/Sandwich/Types/TestTimer.hs index 4f3a53df..ef25e3ed 100644 --- a/sandwich/src/Test/Sandwich/Types/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/Types/TestTimer.hs @@ -145,11 +145,9 @@ newtype TestTimerProfile = TestTimerProfile T.Text newtype TimingLaneSource = TimingLaneSource Unique deriving (Eq) --- | The timing lanes held on one branch of the test tree. Concurrent branches always get their own --- copy, so only one thread writes it at a time. -data TimingLaneState = TimingLaneState { - -- | The sources we're holding a lane from. Claiming a second lane from one of these would - -- deadlock, since only we can release it. - timingLaneSources :: [TimingLaneSource] - , timingLaneProfile :: T.Text +-- | The test timer profile in effect on one branch of the test tree, and the timing lanes it's holding. Concurrent branches always get their own copy, so only one thread writes it at a time. +data TimingProfile = TimingProfile { + timingProfileName :: T.Text + -- | The sources we're holding a lane from. Claiming a second lane from one of these would deadlock, since only we can release it. + , timingProfileLanes :: [TimingLaneSource] } From e7b648e3cda5996326b560bf2947e6d2425a9ffc Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 26 Jul 2026 03:55:19 -0700 Subject: [PATCH 13/15] Fixups noci --- sandwich/src/Test/Sandwich/TestTimer.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/sandwich/src/Test/Sandwich/TestTimer.hs b/sandwich/src/Test/Sandwich/TestTimer.hs index 6acf1ab4..a4a32bc2 100644 --- a/sandwich/src/Test/Sandwich/TestTimer.hs +++ b/sandwich/src/Test/Sandwich/TestTimer.hs @@ -30,6 +30,7 @@ import Control.Monad.Reader import Control.Monad.Trans.State import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL +import Data.Foldable (toList) import qualified Data.List as L import qualified Data.Sequence as S import Data.String.Interpolate @@ -175,9 +176,14 @@ finalizeSpeedScopeTestTimer tt@(SpeedScopeTestTimer {..}) = do renderSpeedScopeFile :: MonadIO m => TestTimer -> m (Maybe BL.ByteString) renderSpeedScopeFile NullTestTimer = return Nothing renderSpeedScopeFile (SpeedScopeTestTimer {..}) = liftIO $ do - endTime <- getPOSIXTime + now <- getPOSIXTime - speedScopeFile <- readMVar testTimerSpeedScopeFile + speedScopeFile <- closeOpenFrames now <$> readMVar testTimerSpeedScopeFile + + -- End at the last thing that happened, rather than at the current time, so that a profile + -- rendered after the tests are done doesn't include all the time since. + let endTime = L.foldl' max testTimerStartTime [time | p <- speedScopeFile ^. profiles + , SpeedScopeEvent _ _ time <- toList (p ^. events)] -- Wrap every test profile in an overall frame called 'allTestsEventName'. If -- we don't do this, the speedscope viewer will show each profile as if it @@ -188,7 +194,7 @@ renderSpeedScopeFile (SpeedScopeTestTimer {..}) = liftIO $ do & prependSpeedScopeEvent testTimerStartTime profileName allTestsEventName SpeedScopeEventTypeOpen & appendSpeedScopeEvent endTime profileName allTestsEventName SpeedScopeEventTypeClose ) - (closeOpenFrames endTime speedScopeFile) + speedScopeFile (fmap (^. name) (speedScopeFile ^. profiles)) return $ Just $ A.encode finalSpeedScopeFile @@ -201,7 +207,6 @@ renderSpeedScopeFile (SpeedScopeTestTimer {..}) = liftIO $ do closeProfile p = p & over events (<> S.fromList [SpeedScopeEvent SpeedScopeEventTypeClose frameID time | frameID <- openFrames (p ^. events)]) - & over endValue (max time) openFrames :: S.Seq SpeedScopeEvent -> [Int] openFrames = L.foldl' step [] From 36a485d6885ab9c705cfc63ca02b802bc1644096 Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 26 Jul 2026 05:10:56 -0700 Subject: [PATCH 14/15] Fixups noci --- sandwich/CHANGELOG.md | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 7fa96ef3..0d15d51f 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -3,21 +3,10 @@ ## Unreleased * TUI: be able to press 'S' to open the speedscope profile in a browser. -* `parallelN` now limits with a pool of lanes rather than a semaphore. The bound is still global - over the whole subtree, including nested `parallel` nodes, but each lane is also a test timer - profile, so you get N profiles instead of one per test. - * Breaking: the `parallelSemaphore` label and `HasParallelSemaphore` are gone; the semaphore now - lives inside the pool. Claim with `withParallelLane` instead of taking the `QSem` yourself. - It's also re-entrant, so hooks that apply at several depths only claim once. - * `parallelN`'s child spec type now has a `parallelLanes` label rather than a `parallelSemaphore` - one; either way it's inferred for specs that are polymorphic in their context. - * `parallelN` now needs `HasBaseContext context`, which specs written against `TopSpec` already - have. -* Add `withParallelLanes`/`withParallelLanesFromArgs` to introduce a lane pool over a spec tree you - can't wrap with `parallelN`, plus `takeParallelLane` to claim a lane for a whole spec (shaped for - `getSpecIndividualSpecHooks`) and `withParallelLane` to claim one inside a handler. -* Add `withTimingLane`, `inTimingLane` and `newTimingLaneSource` to `Test.Sandwich.TestTimer`, for - switching the test timer profile of a whole subtree from an `around` handler. +* `parallelN` now limits with a pool of lanes instead of a semaphore, so a run produces N test timer profiles rather than one per test. The bound still covers the whole subtree, including nested `parallel` nodes. +* BREAKING CHANGE: `parallelN` introduces `parallelLanes` instead of `parallelSemaphore`, and requires `HasBaseContext`. Claim a lane with `withParallelLane` rather than taking the `QSem` yourself; unlike the semaphore, it's re-entrant. +* Add `withParallelLanes`, `withParallelLanesFromArgs` and `takeParallelLane`, for limiting a spec tree you can't wrap with `parallelN` (such as one from `getSpecFromFolder`). +* Add `withTimingLane`, `inTimingLane` and `newTimingLaneSource`, for switching a subtree's test timer profile from an `around` handler. * Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 From 44cc2ebdcbc1f74324773213dfb057475b953eec Mon Sep 17 00:00:00 2001 From: thomasjm Date: Sun, 26 Jul 2026 18:39:06 -0700 Subject: [PATCH 15/15] Fixups noci --- sandwich/CHANGELOG.md | 1 - sandwich/src/Test/Sandwich.hs | 9 --------- 2 files changed, 10 deletions(-) diff --git a/sandwich/CHANGELOG.md b/sandwich/CHANGELOG.md index 0d15d51f..c06c0dea 100644 --- a/sandwich/CHANGELOG.md +++ b/sandwich/CHANGELOG.md @@ -6,7 +6,6 @@ * `parallelN` now limits with a pool of lanes instead of a semaphore, so a run produces N test timer profiles rather than one per test. The bound still covers the whole subtree, including nested `parallel` nodes. * BREAKING CHANGE: `parallelN` introduces `parallelLanes` instead of `parallelSemaphore`, and requires `HasBaseContext`. Claim a lane with `withParallelLane` rather than taking the `QSem` yourself; unlike the semaphore, it's re-entrant. * Add `withParallelLanes`, `withParallelLanesFromArgs` and `takeParallelLane`, for limiting a spec tree you can't wrap with `parallelN` (such as one from `getSpecFromFolder`). -* Add `withTimingLane`, `inTimingLane` and `newTimingLaneSource`, for switching a subtree's test timer profile from an `around` handler. * Don't leave children running when a `parallel` node stops waiting on them early. ## 0.3.1.0 diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index 34178ab4..de013cf7 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/sandwich/src/Test/Sandwich.hs @@ -70,15 +70,6 @@ module Test.Sandwich ( , withTimingProfile , withTimingProfile' - -- ** Timing lanes - -- - -- | For giving a whole subtree a different profile from an 'around' handler. Used by - -- 'withParallelLane'; you only need these if you're building something like it. - , TimingLaneSource - , newTimingLaneSource - , withTimingLane - , inTimingLane - -- * Managed async -- -- | If you want to run asyncs within your tests, we can help keep track of