sydtest 0.15.1.2 → 0.15.1.3

raw patch · 3 files changed

+30/−33 lines, 3 files

Files

• CHANGELOG.md +4/−0
• src/Test/Syd/Runner/Asynchronous.hs +25/−32
• sydtest.cabal +1/−1

@@ -1,5 +1,9 @@ # Changelog +## [0.15.1.3] - 2024-07-20++* Fix race condition in the asynchronous runner+ ## [0.15.1.2] - 2024-07-18  * Fix parsing filter flags so it becomes easy to select tests with spaces in their description

@@ -16,7 +16,6 @@  import Control.Concurrent.Async as Async import Control.Concurrent.MVar-import Control.Concurrent.QSem import Control.Concurrent.STM as STM import Control.Exception import Control.Monad@@ -24,8 +23,6 @@ import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as TIO-import Data.Vector (Vector)-import qualified Data.Vector as V import Data.Word import GHC.Clock (getMonotonicTimeNSec) import Test.QuickCheck.IO ()@@ -71,16 +68,15 @@   { -- | Bounded channel for the jobs.     -- We use a TBQueue because it's bounded and we can check if it's empty.     jobQueueTBQueue :: !(TBQueue Job),-    -- | One semaphore per worker, which needs to be awaited before the worker-    -- can start doing a job.-    jobQueueWorking :: !(Vector QSem)+    -- | Count of the number of job currently executed by workers.+    jobQueueWorkingCount :: !(TVar Int)   } --- | Make a new job queue with a given number of workers and capacity-newJobQueue :: Word -> Word -> IO JobQueue-newJobQueue nbWorkers spots = do+-- | Make a new job queue with a given capacity+newJobQueue :: Word -> IO JobQueue+newJobQueue spots = do   jobQueueTBQueue <- newTBQueueIO (fromIntegral spots)-  jobQueueWorking <- V.replicateM (fromIntegral nbWorkers) (newQSem 1)+  jobQueueWorkingCount <- newTVarIO (fromIntegral (0 :: Word))   pure JobQueue {..}  -- | Enqueue a job, block until that's possible.@@ -89,27 +85,22 @@   atomically $ writeTBQueue jobQueueTBQueue job  -- | Dequeue a job.-dequeueJob :: JobQueue -> IO Job+dequeueJob :: JobQueue -> STM Job dequeueJob JobQueue {..} =-  atomically $ readTBQueue jobQueueTBQueue+  readTBQueue jobQueueTBQueue  -- | Block until all workers are done (waiting to dequeue a job). blockUntilDone :: JobQueue -> IO () blockUntilDone JobQueue {..} = do-  -- Wait until the queue is empty.-  atomically $ isEmptyTBQueue jobQueueTBQueue >>= STM.check-  -- No new work can be started now, because the queue is empty.-  -- That means that all workers are either waiting for another job or still-  -- doing a job.+  atomically $ do+    -- Wait until the queue is empty.+    isEmptyTBQueue jobQueueTBQueue >>= STM.check+    -- Wait for all workers to stop working.+    currentlyRunning <- readTVar jobQueueWorkingCount+    when (currentlyRunning > 0) retry -  -- Wait for all workers to stop working.-  -- That means that they're all just done working now or waiting for another job.-  -- Both are fine.-  V.forM_ jobQueueWorking waitQSem-  -- The workers are now all done and the queue is empty, and this is the only-  -- thread enqueueing jobs, so no work is happening.-  -- Release all the workers so they can work again after this function.-  V.forM_ jobQueueWorking signalQSem+-- No new work can be started now, because the queue is empty and no worker+-- are running.  withJobQueueWorkers :: Word -> JobQueue -> IO a -> IO a withJobQueueWorkers nbWorkers jobQueue func =@@ -122,13 +113,15 @@  jobQueueWorker :: JobQueue -> Int -> IO () jobQueueWorker jobQueue workerIx = do-  let workingSem = jobQueueWorking jobQueue V.! workerIx   forever $ do-    job <- dequeueJob jobQueue-    bracket_-      (waitQSem workingSem)-      (signalQSem workingSem)-      (job workerIx)+    bracket+      ( atomically $ do+          -- Pick a job in queue and increase the count+          modifyTVar' (jobQueueWorkingCount jobQueue) (+ 1)+          dequeueJob jobQueue+      )+      (\_ -> atomically $ modifyTVar' (jobQueueWorkingCount jobQueue) (subtract 1))+      (\job -> job workerIx)  -- The plan is as follows: --@@ -172,7 +165,7 @@ runner settings nbThreads failFastVar handleForest = do   let nbWorkers = nbThreads   let nbSpacesOnTheJobQueue = nbWorkers * 2-  jobQueue <- newJobQueue nbWorkers nbSpacesOnTheJobQueue+  jobQueue <- newJobQueue nbSpacesOnTheJobQueue    withJobQueueWorkers nbWorkers jobQueue $ do     let waitForWorkersDone :: IO ()

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sydtest-version:        0.15.1.2+version:        0.15.1.3 synopsis:       A modern testing framework for Haskell with good defaults and advanced testing features. description:    A modern testing framework for Haskell with good defaults and advanced testing features. Sydtest aims to make the common easy and the hard possible. See https://github.com/NorfairKing/sydtest#readme for more information. category:       Testing