From 9d4b893e02861b24e7ef79348f46149235a9d149 Mon Sep 17 00:00:00 2001 From: Patrick Stevens <3138005+Smaug123@users.noreply.github.com> Date: Sun, 16 Jun 2024 15:43:07 +0100 Subject: [PATCH] Run tests in parallel (#79) --- Consumer/Consumer.fsproj | 1 + Consumer/TestNonParallel.fs | 19 + Consumer/TestParallel.fs | 37 +- Consumer/TestSetUp.fs | 3 +- WoofWare.NUnitTestRunner.Lib/Domain.fs | 1 + WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs | 386 +++++++++++++++--- .../SurfaceBaseline.txt | 4 +- WoofWare.NUnitTestRunner.Lib/TestFixture.fs | 6 +- 8 files changed, 375 insertions(+), 82 deletions(-) create mode 100644 Consumer/TestNonParallel.fs diff --git a/Consumer/Consumer.fsproj b/Consumer/Consumer.fsproj index 8ffe2e0..20c4606 100644 --- a/Consumer/Consumer.fsproj +++ b/Consumer/Consumer.fsproj @@ -10,6 +10,7 @@ + diff --git a/Consumer/TestNonParallel.fs b/Consumer/TestNonParallel.fs new file mode 100644 index 0000000..9f222c2 --- /dev/null +++ b/Consumer/TestNonParallel.fs @@ -0,0 +1,19 @@ +namespace Consumer + +open System +open System.Threading +open NUnit.Framework +open FsUnitTyped + +[] +[] +module TestNonParallel = + let defaults = List.init 40 id + let lock = ref 0 + + [] + let ``Default thing, but not parallel`` (i : int) = + Interlocked.Increment lock |> shouldEqual 1 + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) + lock.Value <- 0 + i |> shouldEqual i diff --git a/Consumer/TestParallel.fs b/Consumer/TestParallel.fs index f9c9060..5478371 100644 --- a/Consumer/TestParallel.fs +++ b/Consumer/TestParallel.fs @@ -1,5 +1,7 @@ namespace Consumer +open System +open System.Threading open NUnit.Framework open FsUnitTyped @@ -7,53 +9,58 @@ open FsUnitTyped [] module TestParallelDefault = - let defaults = List.init 100 id + let defaults = List.init 60 id [] - let ``Default thing`` (i : int) = - System.Console.WriteLine i + let ``Default thing, no scope`` (i : int) = + Console.WriteLine i + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) i |> shouldEqual i [] [] module TestParallelAllScope = - let defaults = List.init 100 id + let defaults = List.init 60 id [] - let ``Default thing`` (i : int) = - System.Console.WriteLine i + let ``Thing, all scope`` (i : int) = + Console.WriteLine i + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) i |> shouldEqual i [] [] module TestParallelSelfScope = - let defaults = List.init 100 id + let defaults = List.init 60 id [] - let ``Default thing`` (i : int) = - System.Console.WriteLine i + let ``Thing, self scope`` (i : int) = + Console.WriteLine i + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) i |> shouldEqual i [] [] module TestParallelChildrenScope = - let defaults = List.init 100 id + let defaults = List.init 60 id [] - let ``Default thing`` (i : int) = - System.Console.WriteLine i + let ``Thing, children scope`` (i : int) = + Console.WriteLine i + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) i |> shouldEqual i [] [] module TestParallelFixturesScope = - let defaults = List.init 100 id + let defaults = List.init 60 id [] - let ``Default thing`` (i : int) = - System.Console.WriteLine i + let ``Thing, fixtures scope`` (i : int) = + Console.WriteLine i + Thread.Sleep (TimeSpan.FromMilliseconds (float i)) i |> shouldEqual i diff --git a/Consumer/TestSetUp.fs b/Consumer/TestSetUp.fs index 4f462c0..f26d1ac 100644 --- a/Consumer/TestSetUp.fs +++ b/Consumer/TestSetUp.fs @@ -47,10 +47,11 @@ module TestSetUp = setUpTimesSeen |> Seq.toList + |> List.sort // Six tests: one for Test, two for the TestCase, three for the Repeat. |> shouldEqual [ 1..6 ] - tearDownTimesSeen |> Seq.toList |> shouldEqual [ 1..6 ] + tearDownTimesSeen |> Seq.toList |> List.sort |> shouldEqual [ 1..6 ] [] let ``Test 1`` () = diff --git a/WoofWare.NUnitTestRunner.Lib/Domain.fs b/WoofWare.NUnitTestRunner.Lib/Domain.fs index c4bcf6b..aea64b6 100644 --- a/WoofWare.NUnitTestRunner.Lib/Domain.fs +++ b/WoofWare.NUnitTestRunner.Lib/Domain.fs @@ -88,6 +88,7 @@ type SingleTestMethod = /// A test fixture (usually represented by the []` attribute), which may contain many tests, /// each of which may run many times. +[] type TestFixture = { /// The assembly which contains this TestFixture, loaded into a separate context. diff --git a/WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs b/WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs index 897e671..4095c31 100644 --- a/WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs +++ b/WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs @@ -36,66 +36,311 @@ type TestFixtureTearDownToken = private | TestFixtureTearDownToken of TestFixtur module private TestFixtureTearDownToken = let vouchNoTearDownRequired (TestFixtureSetupToken tf) = TestFixtureTearDownToken tf +[] type private MailboxMessage = | Quit of AsyncReplyChannel - | RunTest of ThunkCrate + /// Check current state, see if we need to start more tests, etc. + | Reconcile + | RunTest of within : TestFixture * Parallelizable option * test : ThunkCrate | BeginTestFixture of TestFixture * AsyncReplyChannel | EndTestFixture of TestFixtureTearDownToken * AsyncReplyChannel +type private RunningFixture = + { + Fixture : TestFixture + RunningCanParallelize : bool + Running : Task list + Waiting : ((unit -> Task) * Parallelizable option) list + } + + static member Make (f : TestFixture) = + { + Fixture = f + Running = [] + RunningCanParallelize = true + Waiting = [] + } + +type private RunningState = + { + MaxParallelism : int + // TODO: make these efficiently look-up-able + CurrentlyRunning : RunningFixture list + Waiting : (TestFixture * AsyncReplyChannel) list + } + + member this.NewTest (tf : TestFixture) (par : Parallelizable option) (test : unit -> Task) = + { + MaxParallelism = this.MaxParallelism + Waiting = this.Waiting + CurrentlyRunning = + let found = ref 0 + + this.CurrentlyRunning + |> List.map (fun f -> + if Object.ReferenceEquals (f.Fixture, tf) then + Interlocked.Increment found |> ignore + + { f with + Waiting = (test, par) :: f.Waiting + } + else + f + ) + |> fun l -> + match found.Value with + | 1 -> l + | 0 -> failwith $"Unexpectedly did not find the running test fixture '%s{tf.Name}' to add a test to" + | _ -> failwith $"Unexpectedly found the running test fixture '%s{tf.Name}' multiple times in list" + } + + member this.CompleteFixture (tf : TestFixture) : RunningState = + let rec go (acc : RunningFixture list) (running : RunningFixture list) = + match running with + | [] -> failwith "Caller has somehow called EndTestFixture while we're not running that test fixture" + | runningFixture :: tail -> + if Object.ReferenceEquals (runningFixture.Fixture, tf) then + match runningFixture.Running, runningFixture.Waiting with + | [], [] -> acc @ tail + | r, [] -> + failwith $"Caller has called EndTestFixture while its tests are still running (%i{r.Length})" + | [], r -> + failwith $"Caller has called EndTestFixture while it has tests waiting to run (%i{r.Length})" + | r, s -> + failwith + $"Caller has called EndTestFixture while it has tests waiting to run (%i{s.Length}) and test running (%i{r.Length})" + else + go (runningFixture :: acc) tail + + let currentlyRunning = go [] this.CurrentlyRunning + + { + CurrentlyRunning = currentlyRunning + Waiting = this.Waiting + MaxParallelism = this.MaxParallelism + } + type private MailboxState = | Idle - | Running of TestFixture * (TestFixture * AsyncReplyChannel) list + | Running of RunningState /// Run some things in parallel. /// TODO: actually implement the parallelism! Right now this just runs everything serially. /// TODO: consume the cancellation token type ParallelQueue - (_parallelism : int option, _scope : Parallelizable option, ?ct : CancellationToken) + (parallelism : int option, _scope : Parallelizable option, ?ct : CancellationToken) = + let parallelism = + match parallelism with + | None -> max (Environment.ProcessorCount / 2) 2 + | Some p -> p + let rec processTask (state : MailboxState) (m : MailboxProcessor) = async { let! message = m.Receive () match message with - | Quit rc -> rc.Reply () - | BeginTestFixture (tf, rc) -> + | MailboxMessage.Quit rc -> rc.Reply () + | MailboxMessage.Reconcile -> match state with - | Running (current, rest) -> - let state = Running (current, (tf, rc) :: rest) - return! processTask state m - | Idle -> - let state = Running (tf, []) - rc.Reply (TestFixtureRunningToken tf) - return! processTask state m - | EndTestFixture (TestFixtureTearDownToken tf, rc) -> - match state with - | Idle -> - return failwith "Caller has somehow called EndTestFixture while we're not running a test fixture" - | Running (current, rest) -> - if not (Object.ReferenceEquals (current, tf)) then - return - failwith - "Caller has somehow called EndTestFixture while we're not running that test fixture" + | Idle -> return! processTask state m + | Running r -> - rc.Reply () - - match rest with + match r.CurrentlyRunning with + | [] -> + match r.Waiting with | [] -> return! processTask Idle m | (head, rc) :: tail -> rc.Reply (TestFixtureRunningToken head) - return! processTask (Running (head, tail)) m - | RunTest message -> - // Currently we rely on the caller to only send this message when we've given them permission through - // the StartTestFixture method returning. - { new ThunkEvaluator<_> with - member _.Eval t rc = - use ec = ExecutionContext.Capture () - ExecutionContext.Run (ec, (fun _ -> rc.Reply (t ())), ()) - FakeUnit - } - |> message.Apply - |> function - | FakeUnit -> () + + let newRunning = + { + Fixture = head + Running = [] + RunningCanParallelize = true + Waiting = [] + } + + let state = + { + MaxParallelism = r.MaxParallelism + CurrentlyRunning = [ newRunning ] + Waiting = tail + } + // For now, we'll just run one fixture at a time. When we run multiple fixtures in parallel, + // we probably want to call Reconcile here again. + return! processTask (Running state) m + | [ currentlyRunning ] -> + let currentlyRunningTasks = + currentlyRunning.Running |> List.filter (fun t -> not t.IsCompleted) + + let r = + { r with + CurrentlyRunning = + [ + { currentlyRunning with + Running = currentlyRunningTasks + } + ] + } + + match currentlyRunningTasks with + | [] -> + match currentlyRunning.Waiting with + | [] -> + // Nothing to run yet + return! processTask (Running r) m + | (head, par) :: tail -> + let par = + match par with + | None -> true + | Some Parallelizable.No -> false + | Some (Parallelizable.Yes ()) -> true + + let state = + { + Fixture = currentlyRunning.Fixture + RunningCanParallelize = par + Waiting = tail + Running = [ head () ] + } + + m.Post MailboxMessage.Reconcile + + return! + processTask + (Running + { r with + CurrentlyRunning = [ state ] + }) + m + + | currentlyRunningTasks -> + + if currentlyRunningTasks.Length >= parallelism then + return! processTask (Running r) m + else + + match currentlyRunning.Waiting, currentlyRunning.RunningCanParallelize with + | [], _ -> + // No new candidates. + return! processTask (Running r) m + | _, false -> + // The running test(s) can't have others added. + return! processTask (Running r) m + | (head, par) :: tail, true -> + match par with + | Some Parallelizable.No -> return! processTask (Running r) m + | Some (Parallelizable.Yes ()) -> + let state = + { + RunningState.MaxParallelism = r.MaxParallelism + Waiting = r.Waiting + CurrentlyRunning = + [ + { + Fixture = currentlyRunning.Fixture + RunningCanParallelize = true + Running = head () :: currentlyRunning.Running + Waiting = tail + } + ] + } + + m.Post MailboxMessage.Reconcile + return! processTask (Running state) m + | None -> + match currentlyRunning.Fixture.Parallelize with + | Some Parallelizable.No + | Some (Parallelizable.Yes ClassParallelScope.Self) + | Some (Parallelizable.Yes ClassParallelScope.Fixtures) -> + // Can't add this test to the parallel queue right now + return! processTask (Running r) m + | None + | Some (Parallelizable.Yes ClassParallelScope.All) + | Some (Parallelizable.Yes ClassParallelScope.Children) -> + let state = + { + Fixture = currentlyRunning.Fixture + RunningCanParallelize = true + Waiting = tail + Running = (head ()) :: currentlyRunningTasks + } + + m.Post MailboxMessage.Reconcile + + return! + processTask + (Running + { r with + CurrentlyRunning = [ state ] + }) + m + | _ -> failwith "Logic error: we currently only run one fixture at a time" + | MailboxMessage.BeginTestFixture (tf, rc) -> + match state with + | Running state -> + let state = + { + MaxParallelism = state.MaxParallelism + CurrentlyRunning = state.CurrentlyRunning + Waiting = (tf, rc) :: state.Waiting + } + |> Running + + m.Post MailboxMessage.Reconcile + return! processTask state m + | Idle -> + let state = + { + MaxParallelism = parallelism + CurrentlyRunning = [] + Waiting = [ (tf, rc) ] + } + |> Running + + m.Post MailboxMessage.Reconcile + return! processTask state m + | MailboxMessage.EndTestFixture (TestFixtureTearDownToken tf, rc) -> + match state with + | Idle -> + return failwith "Caller has somehow called EndTestFixture while we're not running a test fixture" + | Running state -> + let state = state.CompleteFixture tf + rc.Reply () + m.Post MailboxMessage.Reconcile + return! processTask (Running state) m + | MailboxMessage.RunTest (withinFixture, par, message) -> + let t () = + { new ThunkEvaluator<_> with + member _.Eval<'b> (t : unit -> 'b) rc = + let tcs = TaskCompletionSource () + use ec = ExecutionContext.Capture () + + fun () -> + ExecutionContext.Run ( + ec, + (fun _ -> + let result = t () + tcs.SetResult () + m.Post MailboxMessage.Reconcile + rc.Reply result + ), + () + ) + |> Task.Factory.StartNew + |> ignore + + tcs.Task + } + |> message.Apply + + let state = + match state with + | Idle -> failwith "somehow asked the queue to run tests when there is no active fixture" + | Running state -> state.NewTest withinFixture par t |> Running + + m.Post MailboxMessage.Reconcile return! processTask state m } @@ -103,50 +348,75 @@ type ParallelQueue let mb = new MailboxProcessor<_> (processTask MailboxState.Idle) do mb.Start () - /// Request to run the given action on its own, not in parallel with anything else. - /// The resulting Task will return when the action has completed. - member _.NonParallel<'a> (parent : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task = - ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask - /// Request to run the given action, freely in parallel with other running tests. /// The resulting Task will return when the action has completed. - member _.Parallel<'a> (parent : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task = - ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask - - /// Request to run the given action, obeying the parallelism constraints of the parent test fixture. - /// The resulting Task will return when the action has completed. - member _.ObeyParent<'a> (tf : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task = - ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask + member _.Run<'a> + (TestFixtureSetupToken parent) + (scope : Parallelizable option) + (action : unit -> 'a) + : 'a Task + = + (fun rc -> MailboxMessage.RunTest (parent, scope, ThunkCrate.make action rc)) + |> mb.PostAndAsyncReply + |> Async.StartAsTask /// Declare that we wish to start the given test fixture. The resulting Task will return /// when you are allowed to start running tests from that fixture. /// Once you've finished running tests from that fixture, call EndTestFixture. member _.StartTestFixture (tf : TestFixture) : Task = - fun rc -> BeginTestFixture (tf, rc) + fun rc -> MailboxMessage.BeginTestFixture (tf, rc) |> mb.PostAndAsyncReply |> Async.StartAsTask /// Run the given one-time setup for the test fixture. - member _.RunTestSetup (TestFixtureRunningToken tf) (action : unit -> 'a) : ('a * TestFixtureSetupToken) Task = + member _.RunTestSetup (TestFixtureRunningToken parent) (action : unit -> 'a) : ('a * TestFixtureSetupToken) Task = task { - let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply - return response, TestFixtureSetupToken tf + let par = + parent.Parallelize + |> Option.map (fun p -> + match p with + | Parallelizable.No -> Parallelizable.No + | Parallelizable.Yes _ -> Parallelizable.Yes () + ) + + let! response = + (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc)) + |> mb.PostAndAsyncReply + + return response, TestFixtureSetupToken parent } /// Run the given one-time tear-down for the test fixture. - member _.RunTestTearDown (TestFixtureSetupToken tf) (action : unit -> 'a) : ('a * TestFixtureTearDownToken) Task = + member _.RunTestTearDown + (TestFixtureSetupToken parent) + (action : unit -> 'a) + : ('a * TestFixtureTearDownToken) Task + = task { - let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply - return response, TestFixtureTearDownToken tf + let par = + parent.Parallelize + |> Option.map (fun p -> + match p with + | Parallelizable.No -> Parallelizable.No + | Parallelizable.Yes _ -> Parallelizable.Yes () + ) + + let! response = + (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc)) + |> mb.PostAndAsyncReply + + return response, TestFixtureTearDownToken parent } /// Declare that we have finished submitting requests to run in the given test fixture. /// You don't need to worry about when the resulting Task returns, but we provide it just in case. member _.EndTestFixture (tf : TestFixtureTearDownToken) : Task = - (fun rc -> EndTestFixture (tf, rc)) |> mb.PostAndAsyncReply |> Async.StartAsTask + (fun rc -> MailboxMessage.EndTestFixture (tf, rc)) + |> mb.PostAndAsyncReply + |> Async.StartAsTask interface IDisposable with member _.Dispose () = // Still race conditions, of course: people could still be submitting after we finish the sync. - mb.PostAndReply Quit + mb.PostAndReply MailboxMessage.Quit (mb :> IDisposable).Dispose () diff --git a/WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt b/WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt index 7720360..a608830 100644 --- a/WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt +++ b/WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt @@ -200,9 +200,7 @@ WoofWare.NUnitTestRunner.Parallelizable`1.Tag [property]: [read-only] int WoofWare.NUnitTestRunner.ParallelQueue inherit obj, implements IDisposable WoofWare.NUnitTestRunner.ParallelQueue..ctor [constructor]: (int option, WoofWare.NUnitTestRunner.AssemblyParallelScope WoofWare.NUnitTestRunner.Parallelizable option, System.Threading.CancellationToken option) WoofWare.NUnitTestRunner.ParallelQueue.EndTestFixture [method]: WoofWare.NUnitTestRunner.TestFixtureTearDownToken -> unit System.Threading.Tasks.Task -WoofWare.NUnitTestRunner.ParallelQueue.NonParallel [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task -WoofWare.NUnitTestRunner.ParallelQueue.ObeyParent [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task -WoofWare.NUnitTestRunner.ParallelQueue.Parallel [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task +WoofWare.NUnitTestRunner.ParallelQueue.Run [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> unit WoofWare.NUnitTestRunner.Parallelizable option -> (unit -> 'a) -> 'a System.Threading.Tasks.Task WoofWare.NUnitTestRunner.ParallelQueue.RunTestSetup [method]: WoofWare.NUnitTestRunner.TestFixtureRunningToken -> (unit -> 'a) -> ('a * WoofWare.NUnitTestRunner.TestFixtureSetupToken) System.Threading.Tasks.Task WoofWare.NUnitTestRunner.ParallelQueue.RunTestTearDown [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> ('a * WoofWare.NUnitTestRunner.TestFixtureTearDownToken) System.Threading.Tasks.Task WoofWare.NUnitTestRunner.ParallelQueue.StartTestFixture [method]: WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.TestFixtureRunningToken System.Threading.Tasks.Task diff --git a/WoofWare.NUnitTestRunner.Lib/TestFixture.fs b/WoofWare.NUnitTestRunner.Lib/TestFixture.fs index cbca890..01d1f4f 100644 --- a/WoofWare.NUnitTestRunner.Lib/TestFixture.fs +++ b/WoofWare.NUnitTestRunner.Lib/TestFixture.fs @@ -401,11 +401,7 @@ module TestFixture = result, meta - let! results, summary = - match test.Parallelize with - | Some Parallelizable.No -> par.NonParallel running runMe - | Some (Parallelizable.Yes _) -> par.Parallel running runMe - | None -> par.ObeyParent running runMe + let! results, summary = par.Run running test.Parallelize runMe match results with | Ok results -> return Ok results, summary