diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModule.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModule.fs index 213ff435adf..e3ead3bc768 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModule.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncModule.fs @@ -379,23 +379,23 @@ type AsyncModule() = member _.``AwaitWaitHandle.DisposedWaitHandle2``() = let wh = new ManualResetEvent(false) let started = new ManualResetEventSlim(false) - - let test = - async { + let cts = new CancellationTokenSource() + let test = + Async.StartAsTask( async { + printfn "starting the test" started.Set() - let! timeout = Async.AwaitWaitHandle(wh, 5000) - Assert.False(timeout, "Timeout expected") - } - |> Async.StartAsTask - - task { - started.Wait() - // Wait a moment then dispose waithandle - nothing should happen - do! Task.Delay 500 - Assert.False(test.IsCompleted, "Test completed too early") - dispose wh - do! test - } + let! _ = Async.AwaitWaitHandle(wh) + printfn "should never get here" + }, cancellationToken = cts.Token) + + // Wait for the test to start then dispose waithandle - nothing should happen. + started.Wait() + Assert.False(test.Wait 100, "Test completed too early.") + printfn "disposing" + dispose wh + printfn "cancelling in 1 second" + cts.CancelAfter 1000 + Assert.ThrowsAsync(fun () -> test) [] member _.``RunSynchronously.NoThreadJumpsAndTimeout``() = @@ -469,21 +469,27 @@ type AsyncModule() = member _.``error on one workflow should cancel all others``() = task { use failOnlyOne = new Semaphore(0, 1) - let mutable cancelled = 0 - let mutable started = 0 + // Start from 1. + let mutable running = new CountdownEvent(1) let job i = async { - Interlocked.Increment &started |> ignore - use! holder = Async.OnCancel (fun () -> Interlocked.Increment &cancelled |> ignore) + use! holder = Async.OnCancel (running.Signal >> ignore) + running.AddCount 1 do! failOnlyOne |> Async.AwaitWaitHandle |> Async.Ignore + running.Signal() |> ignore failwith "boom" } let test = Async.Parallel [ for i in 1 .. 100 -> job i ] |> Async.Catch |> Async.Ignore |> Async.StartAsTask - do! Task.Delay 100 + // Wait for more than one job to start + while running.CurrentCount < 2 do + do! Task.Yield() + printfn $"started jobs: {running.CurrentCount - 1}" failOnlyOne.Release() |> ignore do! test - Assert.Equal(started - 1, cancelled) + // running.CurrentCount should eventually settle back at 1. Signal it one more time and it should be 0. + running.Signal() |> ignore + return! Async.AwaitWaitHandle running.WaitHandle } [] diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs index 1b15be8fa98..97ea8fca1a8 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/AsyncType.fs @@ -67,6 +67,8 @@ type AsyncType() = |> Async.Parallel |> Async.RunSynchronously |> Set.ofArray + printfn $"RunSynchronously used {usedThreads.Count} threads. Environment.ProcessorCount is {Environment.ProcessorCount}." + // Some arbitrary large number but in practice it should not use more threads than there are CPU cores. Assert.True(usedThreads.Count < 256, $"RunSynchronously used {usedThreads.Count} threads.") [] diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Cancellation.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Cancellation.fs index a2a97e4d58c..b4a75843369 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Cancellation.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Cancellation.fs @@ -12,6 +12,15 @@ open System.Threading.Tasks type CancellationType() = + let ordered() = + let mutable current = 1 + + fun n -> + async { + SpinWait.SpinUntil(fun () -> current = n) + Interlocked.Increment ¤t |> ignore + } + [] member this.CancellationNoCallbacks() = let _ : CancellationTokenSource = null // compilation test @@ -234,6 +243,8 @@ type CancellationType() = // See https://github.com/dotnet/fsharp/issues/3254 [] member this.AwaitTaskCancellationAfterAsyncTokenCancellation() = + let step = ordered() + let StartCatchCancellation cancellationToken (work) = Async.FromContinuations(fun (cont, econt, _) -> // When the child is cancelled, report OperationCancelled @@ -267,25 +278,26 @@ type CancellationType() = let tcs = System.Threading.Tasks.TaskCompletionSource<_>() let t = async { + do! step 1 do! tcs.Task |> Async.AwaitTask } |> StartAsTaskProperCancel None (Some cts.Token) // First cancel the token, then set the task as cancelled. - async { - do! Async.Sleep 100 + task { + do! step 2 cts.Cancel() - do! Async.Sleep 100 + do! step 3 tcs.TrySetException (TimeoutException "Task timed out after token.") - |> ignore - } |> Async.Start + |> ignore - try - let res = t.Wait(2000) - let msg = sprintf "Excepted TimeoutException wrapped in an AggregateException, but got %A" res - printfn "failure msg: %s" msg - Assert.Fail (msg) - with :? AggregateException as agg -> () + try + let res = t.Wait() + let msg = sprintf "Excepted TimeoutException wrapped in an AggregateException, but got %A" res + printfn "failure msg: %s" msg + Assert.Fail (msg) + with :? AggregateException as agg -> () + } // Simpler regression test for https://github.com/dotnet/fsharp/issues/3254 [] diff --git a/tests/FSharp.Test.Utilities/DirectoryAttribute.fs b/tests/FSharp.Test.Utilities/DirectoryAttribute.fs index c1561fa6c9b..1266bc295a8 100644 --- a/tests/FSharp.Test.Utilities/DirectoryAttribute.fs +++ b/tests/FSharp.Test.Utilities/DirectoryAttribute.fs @@ -9,6 +9,7 @@ open Xunit.Sdk open FSharp.Compiler.IO open FSharp.Test.Compiler open FSharp.Test.Utilities +open TestFramework /// Attribute to use with Xunit's TheoryAttribute. /// Takes a directory, relative to current test suite's root. @@ -22,7 +23,6 @@ type DirectoryAttribute(dir: string) = invalidArg "dir" "Directory cannot be null, empty or whitespace only." let dirInfo = normalizePathSeparator (Path.GetFullPath(dir)) - let outputDirectory methodName extraDirectory = getTestOutputDirectory dir methodName extraDirectory let mutable baselineSuffix = "" let mutable includes = Array.empty @@ -31,19 +31,8 @@ type DirectoryAttribute(dir: string) = | true -> Some (File.ReadAllText path) | _ -> None - let createCompilationUnit path (filename: string) methodName multipleFiles = - // if there are multiple files being processed, add extra directory for each test to avoid reference file conflicts - let extraDirectory = - if multipleFiles then - let extension = Path.GetExtension(filename) - filename.Substring(0, filename.Length - extension.Length) // remove .fs/the extension - |> normalizeName - else "" - let outputDirectory = outputDirectory methodName extraDirectory - let outputDirectoryPath = - match outputDirectory with - | Some path -> path.FullName - | None -> failwith "Can't set the output directory" + let createCompilationUnit path (filename: string) = + let outputDirectoryPath = createTemporaryDirectory "dir" let sourceFilePath = normalizePathSeparator (path ++ filename) let fsBslFilePath = sourceFilePath + baselineSuffix + ".err.bsl" let ilBslFilePath = @@ -97,7 +86,7 @@ type DirectoryAttribute(dir: string) = Name = Some filename IgnoreWarnings = false References = [] - OutputDirectory = outputDirectory + OutputDirectory = Some (DirectoryInfo(outputDirectoryPath)) TargetFramework = TargetFramework.Current StaticLink = false } |> FS @@ -107,7 +96,7 @@ type DirectoryAttribute(dir: string) = member _.BaselineSuffix with get() = baselineSuffix and set v = baselineSuffix <- v member _.Includes with get() = includes and set v = includes <- v - override _.GetData(method: MethodInfo) = + override _.GetData _ = if not (Directory.Exists(dirInfo)) then failwith (sprintf "Directory does not exist: \"%s\"." dirInfo) @@ -127,8 +116,6 @@ type DirectoryAttribute(dir: string) = if not <| FileSystem.FileExistsShim(f) then failwithf "Requested file \"%s\" not found.\nAll files: %A.\nIncludes:%A." f allFiles includes - let multipleFiles = fsFiles |> Array.length > 1 - fsFiles - |> Array.map (fun fs -> createCompilationUnit dirInfo fs method.Name multipleFiles) + |> Array.map (fun fs -> createCompilationUnit dirInfo fs) |> Seq.map (fun c -> [| c |]) diff --git a/tests/FSharp.Test.Utilities/ProjectGeneration.fs b/tests/FSharp.Test.Utilities/ProjectGeneration.fs index a75784240dd..dec0a258e7a 100644 --- a/tests/FSharp.Test.Utilities/ProjectGeneration.fs +++ b/tests/FSharp.Test.Utilities/ProjectGeneration.fs @@ -30,6 +30,7 @@ open FSharp.Compiler.Diagnostics open FSharp.Compiler.Text open Xunit +open FSharp.Test.Utilities open OpenTelemetry open OpenTelemetry.Resources @@ -224,10 +225,7 @@ let sourceFile fileId deps = IsPhysicalFile = false } -let OptionsCache = ConcurrentDictionary() - - - +let OptionsCache = ConcurrentDictionary<_, Lazy>() type SyntheticProject = { Name: string @@ -295,7 +293,7 @@ type SyntheticProject = member this.GetProjectOptions(checker: FSharpChecker) = - let cacheKey = + let key = this.GetAllFiles() |> List.collect (fun (p, f) -> [ p.Name @@ -305,53 +303,56 @@ type SyntheticProject = this.FrameworkReferences, this.NugetReferences - if not (OptionsCache.ContainsKey cacheKey) then - OptionsCache[cacheKey] <- - use _ = Activity.start "SyntheticProject.GetProjectOptions" [ "project", this.Name ] + let factory _ = + lazy + use _ = Activity.start "SyntheticProject.GetProjectOptions" [ "project", this.Name ] - let referenceScript = - seq { - yield! this.FrameworkReferences |> Seq.map getFrameworkReference + let referenceScript = + seq { + yield! this.FrameworkReferences |> Seq.map getFrameworkReference + if not this.NugetReferences.IsEmpty then this.NugetReferences |> getNugetReferences (Some "https://api.nuget.org/v3/index.json") - } - |> String.concat "\n" - - let baseOptions, _ = - checker.GetProjectOptionsFromScript( - "file.fsx", - SourceText.ofString referenceScript, - assumeDotNetFramework = false - ) - |> Async.RunSynchronously - - { - ProjectFileName = this.ProjectFileName - ProjectId = None - SourceFiles = - [| for f in this.SourceFiles do - if f.HasSignatureFile then - this.ProjectDir ++ f.SignatureFileName - - this.ProjectDir ++ f.FileName |] - OtherOptions = - Set [ - yield! baseOptions.OtherOptions - "--optimize+" - for p in this.DependsOn do - $"-r:{p.OutputFilename}" - yield! this.OtherOptions ] - |> Set.toArray - ReferencedProjects = - [| for p in this.DependsOn do - FSharpReferencedProject.FSharpReference(p.OutputFilename, p.GetProjectOptions checker) |] - IsIncompleteTypeCheckEnvironment = false - UseScriptResolutionRules = this.UseScriptResolutionRules - LoadTime = DateTime() - UnresolvedReferences = None - OriginalLoadReferences = [] - Stamp = None } - - OptionsCache[cacheKey] + } + |> String.concat "\n" + + let baseOptions, _ = + checker.GetProjectOptionsFromScript( + "file.fsx", + SourceText.ofString referenceScript, + assumeDotNetFramework = false + ) + |> Async.RunImmediate + + { + ProjectFileName = this.ProjectFileName + ProjectId = None + SourceFiles = + [| for f in this.SourceFiles do + if f.HasSignatureFile then + this.ProjectDir ++ f.SignatureFileName + + this.ProjectDir ++ f.FileName |] + OtherOptions = + Set [ + yield! baseOptions.OtherOptions + "--optimize+" + for p in this.DependsOn do + $"-r:{p.OutputFilename}" + yield! this.OtherOptions ] + |> Set.toArray + ReferencedProjects = + [| for p in this.DependsOn do + FSharpReferencedProject.FSharpReference(p.OutputFilename, p.GetProjectOptions checker) |] + IsIncompleteTypeCheckEnvironment = false + UseScriptResolutionRules = this.UseScriptResolutionRules + LoadTime = DateTime() + UnresolvedReferences = None + OriginalLoadReferences = [] + Stamp = None } + + + OptionsCache.GetOrAdd(key, factory).Value + member this.GetAllProjects() = [ this @@ -1027,11 +1028,12 @@ type ProjectWorkflowBuilder member this.Execute(workflow: Async) = try - Async.RunSynchronously(workflow, timeout = defaultArg runTimeout 600_000) + // We don't want the defaultCancellationToken. + Async.RunSynchronously(workflow, cancellationToken = Threading.CancellationToken.None, ?timeout = runTimeout) finally if initialContext.IsNone && not isExistingProject then this.DeleteProjectDir() - activity |> Option.iter (fun x -> x.Dispose()) + activity |> Option.iter (fun x -> if not (isNull x) then x.Dispose()) tracerProvider |> Option.iter (fun x -> x.ForceFlush() |> ignore x.Dispose()) @@ -1135,14 +1137,10 @@ type ProjectWorkflowBuilder async { let! ctx = workflow - use activity = - Activity.start "ProjectWorkflowBuilder.CheckFile" [ Activity.Tags.project, initialProject.Name; "fileId", fileId ] - let! results = + use _ = Activity.start "ProjectWorkflowBuilder.CheckFile" [ Activity.Tags.project, initialProject.Name; "fileId", fileId ] checkFile fileId ctx.Project checker - activity.Dispose() - let oldSignature = ctx.Signatures[fileId] let newSignature = getSignature results