Some more assorted tests improvements

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<TaskCanceledException>(fun () -> test)
 
     [<Fact>]
     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
         }
 
     [<Fact>]

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.")
 
     [<Theory>]

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 &current |> ignore
+            }
+
     [<Fact>]
     member this.CancellationNoCallbacks() =
         let _ : CancellationTokenSource = null // compilation test
@@ -234,6 +243,8 @@ type CancellationType() =
     // See https://github.com/dotnet/fsharp/issues/3254
     [<Fact>]
     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
     [<Fact>]

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<string>
 
@@ -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 |])

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<FSharpProjectOptions>>()
 
 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<WorkflowContext>) =
         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