From ad8314d0df62a4faa73357d02a53b7369eee39fa Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 15:16:44 +0100 Subject: [PATCH 1/9] fix 11797 --- src/fsharp/FSharp.Core/async.fs | 181 ++++++++------- .../Microsoft.FSharp.Control/AsyncType.fs | 208 +++++++----------- 2 files changed, 160 insertions(+), 229 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index 0d5abef0333..f8037207c76 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -237,41 +237,41 @@ namespace Microsoft.FSharp.Control member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } /// Produce a new execution context for a composite async - member ctxt.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } + member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } /// Produce a new execution context for a composite async - member ctxt.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } + member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } /// Produce a new execution context for a composite async member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } /// The extra information relevant to the execution of the async - member ctxt.aux = contents.aux + member _.aux = contents.aux /// The success continuation relevant to the execution of the async - member ctxt.cont = contents.cont + member _.cont = contents.cont /// The exception continuation relevant to the execution of the async - member ctxt.econt = contents.aux.econt + member _.econt = contents.aux.econt /// The cancellation continuation relevant to the execution of the async - member ctxt.ccont = contents.aux.ccont + member _.ccont = contents.aux.ccont /// The cancellation token relevant to the execution of the async - member ctxt.token = contents.aux.token + member _.token = contents.aux.token /// The trampoline holder being used to protect execution of the async - member ctxt.trampolineHolder = contents.aux.trampolineHolder + member _.trampolineHolder = contents.aux.trampolineHolder /// Check if cancellation has been requested - member ctxt.IsCancellationRequested = contents.aux.token.IsCancellationRequested + member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested /// Call the cancellation continuation of the active computation - member ctxt.OnCancellation () = + member _.OnCancellation () = contents.aux.ccont (OperationCanceledException (contents.aux.token)) /// Check for trampoline hijacking. - member inline ctxt.HijackCheckThenCall cont arg = + member inline _.HijackCheckThenCall cont arg = contents.aux.trampolineHolder.HijackCheckThenCall cont arg /// Call the success continuation of the asynchronous execution context after checking for @@ -283,7 +283,7 @@ namespace Microsoft.FSharp.Control ctxt.HijackCheckThenCall ctxt.cont result /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member ctxt.OnExceptionRaised() = + member _.OnExceptionRaised() = contents.aux.trampolineHolder.OnExceptionRaised contents.aux.econt /// Make an initial async activation. @@ -394,24 +394,6 @@ namespace Microsoft.FSharp.Control else fake() - /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) - [] - let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) userCode result1 = - let mutable res = Unchecked.defaultof<_> - let mutable ok = false - - try - res <- userCode result1 - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - res.Invoke ctxt - else - fake() - /// Apply 'catchFilter' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' /// then send 'result1' to the exception continuation. [] @@ -459,31 +441,30 @@ namespace Microsoft.FSharp.Control [] // Note: direct calls to this function end up in user assemblies via inlining let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = + // We do a cancellation check before the Bind, but not after. This is because we may be about to enter + // a TryFinally if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt part2 result1 )) + Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvoke ctxt result1 part2)) [] /// Re-route all continuations to execute the finally function. let TryFinally (ctxt: AsyncActivation<'T>) computation finallyFunction = - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - // The new continuation runs the finallyFunction and resumes the old continuation - // If an exception is thrown we continue with the previous exception continuation. - let cont result = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) - // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. - // If an exception is thrown we continue with the previous exception continuation. - let econt exn = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt exn)) - // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. - // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) - let ccont cexn = - CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) - let newCtxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) - computation.Invoke newCtxt + // The new continuation runs the finallyFunction and resumes the old continuation + // If an exception is thrown we continue with the previous exception continuation. + let cont result = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) + // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. + // If an exception is thrown we continue with the previous exception continuation. + let econt exn = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt exn)) + // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. + // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) + let ccont cexn = + CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + let newCtxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) + computation.Invoke newCtxt /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. /// If it returns Some, invoke the resulting async. @@ -506,7 +487,7 @@ namespace Microsoft.FSharp.Control let CreateProtectedAsync f = MakeAsync (fun ctxt -> ProtectedCode ctxt f) - /// Internal way of making an async from result, for exact code compat. + /// Make an async from an AsyncResult let CreateAsyncResultAsync res = MakeAsync (fun ctxt -> match res with @@ -625,7 +606,8 @@ namespace Microsoft.FSharp.Control ccont = (fun x -> ctxt.trampolineHolder.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont x))) // When run, ensures that each of the continuations of the process are run in the same synchronization context. - let CreateDelimitedUserCodeAsync f = + // Also protects 'f' which should not actually call any of the continuations of 'ctxt' + let CreateDelimitedProtectedAsync f = CreateProtectedAsync (fun ctxt -> let ctxtWithSync = DelimitSyncContext ctxt f ctxtWithSync) @@ -921,46 +903,59 @@ namespace Microsoft.FSharp.Control |> unfake task - // Helper to attach continuation to the given task. + // Call the appropriate continuation on completion of a task [] - let taskContinueWith (task: Task<'T>) (ctxt: AsyncActivation<'T>) = - - let continuation (completedTask: Task<_>) : unit = - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - if completedTask.IsCanceled then - let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) - ctxt.econt edi - elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception - ctxt.econt edi - else - ctxt.cont completedTask.Result) |> unfake - - if task.IsCompleted then - continuation task |> fake + let OnTaskCompleted (completedTask: Task<'T>) (ctxt: AsyncActivation<'T>) = + assert completedTask.IsCompleted + if completedTask.IsCanceled then + let edi = ExceptionDispatchInfo.Capture(TaskCanceledException completedTask) + ctxt.econt edi + elif completedTask.IsFaulted then + let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + ctxt.econt edi else - task.ContinueWith(Action>(continuation), TaskContinuationOptions.ExecuteSynchronously) - |> ignore |> fake + ctxt.cont completedTask.Result + // Call the appropriate continuation on completion of a task. A cancelled task + // calls the exception continuation with TaskCanceledException, since it may not represent cancellation of + // the overall async (they may be governed by different cancellation tokens, or + // the task may not have a cancellation token at all). [] - let taskContinueWithUnit (task: Task) (ctxt: AsyncActivation) = + let OnUnitTaskCompleted (completedTask: Task) (ctxt: AsyncActivation) = + assert completedTask.IsCompleted + if completedTask.IsCanceled then + let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) + ctxt.econt edi + elif completedTask.IsFaulted then + let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception + ctxt.econt edi + else + ctxt.cont () - let continuation (completedTask: Task) : unit = + // Helper to attach continuation to the given task, which is assumed not to be completed. + // When the task completes the continuation will be run asynchronously in the thread pool + // with trampoline protection. + [] + let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = + task.ContinueWith(Action>(fun completedTask -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> - if completedTask.IsCanceled then - let edi = ExceptionDispatchInfo.Capture(TaskCanceledException(completedTask)) - ctxt.econt edi - elif completedTask.IsFaulted then - let edi = ExceptionDispatchInfo.RestoreOrCapture completedTask.Exception - ctxt.econt edi - else - ctxt.cont ()) |> unfake - - if task.IsCompleted then - continuation task |> fake - else - task.ContinueWith(Action(continuation), TaskContinuationOptions.ExecuteSynchronously) - |> ignore |> fake + OnTaskCompleted completedTask ctxt) + |> unfake)) + |> ignore + |> fake + + // Helper to attach continuation to the given task, which is assumed not to be completed + // When the task completes the continuation will be run asynchronously in the thread pool + // with trampoline protection. + [] + let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = + task.ContinueWith(Action(fun completedTask -> + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> + OnUnitTaskCompleted completedTask ctxt) + |> unfake + )) + |> ignore + |> fake [] type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state:obj) = @@ -1358,7 +1353,7 @@ namespace Microsoft.FSharp.Control AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore static member Sleep (millisecondsDueTime: int64) : Async = - CreateDelimitedUserCodeAsync (fun ctxt -> + CreateDelimitedProtectedAsync (fun ctxt -> let mutable timer = None: Timer option let cont = ctxt.cont let ccont = ctxt.ccont @@ -1419,7 +1414,7 @@ namespace Microsoft.FSharp.Control let ok = waitHandle.WaitOne(0, exitContext=false) async.Return ok) else - CreateDelimitedUserCodeAsync(fun ctxt -> + CreateDelimitedProtectedAsync(fun ctxt -> let aux = ctxt.aux let rwh = ref (None: RegisteredWaitHandle option) let latch = Latch() @@ -1468,11 +1463,7 @@ namespace Microsoft.FSharp.Control /// Bind the result of a result cell, calling the appropriate continuation. static member BindResult (result: AsyncResult<'T>) : Async<'T> = - MakeAsync (fun ctxt -> - (match result with - | Ok v -> ctxt.cont v - | Error exn -> ctxt.econt exn - | Canceled exn -> ctxt.ccont exn) ) + CreateAsyncResultAsync result /// Await and use the result of a result cell. The resulting async doesn't support cancellation /// or timeout directly, rather the underlying computation must fill the result if cancellation @@ -1693,15 +1684,15 @@ namespace Microsoft.FSharp.Control static member AwaitTask (task:Task<'T>) : Async<'T> = if task.IsCompleted then - CreateProtectedAsync (fun ctxt -> taskContinueWith task ctxt) + MakeAsync (fun ctxt -> OnTaskCompleted task ctxt) else - CreateDelimitedUserCodeAsync (fun ctxt -> taskContinueWith task ctxt) + CreateDelimitedProtectedAsync (fun ctxt -> AttachContinuationToTask task ctxt) static member AwaitTask (task:Task) : Async = if task.IsCompleted then - CreateProtectedAsync (fun ctxt -> taskContinueWithUnit task ctxt) + MakeAsync (fun ctxt -> OnUnitTaskCompleted task ctxt) else - CreateDelimitedUserCodeAsync (fun ctxt -> taskContinueWithUnit task ctxt) + CreateDelimitedProtectedAsync (fun ctxt -> AttachContinuationToUnitTask task ctxt) module CommonExtensions = 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 689bcec6d1b..6247da500b7 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 @@ -21,9 +21,12 @@ type AsyncType() = let ignoreSynchCtx f = f () + let waitASec (t:Task) = + let result = t.Wait(TimeSpan(hours=0,minutes=0,seconds=1)) + Assert.True(result, "Task did not finish after waiting for a second.") [] - member this.StartWithContinuations() = + member _.StartWithContinuations() = let whatToDo = ref Exit @@ -75,7 +78,7 @@ type AsyncType() = () [] - member this.AsyncRunSynchronouslyReusesThreadPoolThread() = + member _.AsyncRunSynchronouslyReusesThreadPoolThread() = let action = async { async { () } |> Async.RunSynchronously } let computation = [| for i in 1 .. 1000 -> action |] @@ -90,7 +93,7 @@ type AsyncType() = [] [] [] - member this.AsyncSleepCancellation1(sleepType) = + member _.AsyncSleepCancellation1(sleepType) = ignoreSynchCtx (fun () -> let computation = match sleepType with @@ -112,7 +115,7 @@ type AsyncType() = [] [] [] - member this.AsyncSleepCancellation2(sleepType) = + member _.AsyncSleepCancellation2(sleepType) = ignoreSynchCtx (fun () -> let computation = match sleepType with @@ -137,7 +140,7 @@ type AsyncType() = [] [] [] - member this.AsyncSleepThrowsOnNegativeDueTimes(sleepType) = + member _.AsyncSleepThrowsOnNegativeDueTimes(sleepType) = async { try do! match sleepType with @@ -150,7 +153,7 @@ type AsyncType() = } |> Async.RunSynchronously [] - member this.AsyncSleepInfinitely() = + member _.AsyncSleepInfinitely() = ignoreSynchCtx (fun () -> let computation = Async.Sleep(System.Threading.Timeout.Infinite) let result = TaskCompletionSource() @@ -164,27 +167,17 @@ type AsyncType() = Assert.AreEqual("Cancel", result) ) - member private this.WaitASec (t:Task) = - let result = t.Wait(TimeSpan(hours=0,minutes=0,seconds=1)) - Assert.True(result, "Task did not finish after waiting for a second.") - - [] - member this.CreateTask () = + member _.CreateTask () = let s = "Hello tasks!" let a = async { return s } -#if !NET46 - let t : Task = -#else - use t : Task = -#endif - Async.StartAsTask a - this.WaitASec t + use t : Task = Async.StartAsTask a + waitASec t Assert.True (t.IsCompleted) Assert.AreEqual(s, t.Result) [] - member this.StartAsTaskCancellation () = + member _.StartAsTaskCancellation () = let cts = new CancellationTokenSource() let mutable spinloop = true let doSpinloop () = while spinloop do () @@ -192,12 +185,7 @@ type AsyncType() = cts.CancelAfter (100) doSpinloop() } -#if !NET46 - let t : Task = -#else - use t : Task = -#endif - Async.StartAsTask(a, cancellationToken = cts.Token) + use t : Task = Async.StartAsTask(a, cancellationToken = cts.Token) // Should not finish, we don't eagerly mark the task done just because it's been signaled to cancel. try @@ -208,7 +196,7 @@ type AsyncType() = spinloop <- false try - this.WaitASec t + waitASec t with :? AggregateException as a -> match a.InnerException with | :? TaskCanceledException as t -> () @@ -216,7 +204,7 @@ type AsyncType() = Assert.True (t.IsCompleted, "Task is not completed") [] - member this.``AwaitTask ignores Async cancellation`` () = + member _.``AwaitTask ignores Async cancellation`` () = let cts = new CancellationTokenSource() let tcs = new TaskCompletionSource() let innerTcs = new TaskCompletionSource() @@ -233,7 +221,7 @@ type AsyncType() = innerTcs.SetResult () try - this.WaitASec tcs.Task + waitASec tcs.Task with :? AggregateException as a -> match a.InnerException with | :? TaskCanceledException -> () @@ -241,7 +229,7 @@ type AsyncType() = Assert.True (tcs.Task.IsCompleted, "Task is not completed") [] - member this.RunSynchronouslyCancellationWithDelayedResult () = + member _.RunSynchronouslyCancellationWithDelayedResult () = let cts = new CancellationTokenSource() let tcs = TaskCompletionSource() let _ = cts.Token.Register(fun () -> tcs.SetResult 42) @@ -260,45 +248,35 @@ type AsyncType() = Assert.True (cancelled, "Task is not cancelled") [] - member this.ExceptionPropagatesToTask () = + member _.ExceptionPropagatesToTask () = let a = async { do raise (Exception ()) } -#if !NET46 - let t = -#else - use t = -#endif - Async.StartAsTask a + use t = Async.StartAsTask a let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (t.IsFaulted) Assert.True(exceptionThrown) [] - member this.CancellationPropagatesToTask () = + member _.CancellationPropagatesToTask () = let a = async { while true do () } -#if !NET46 - let t = -#else - use t = -#endif - Async.StartAsTask a + use t = Async.StartAsTask a Async.CancelDefaultToken () let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (exceptionThrown) Assert.True(t.IsCanceled) [] - member this.CancellationPropagatesToGroup () = + member _.CancellationPropagatesToGroup () = let ewh = new ManualResetEvent(false) let cancelled = ref false let a = async { @@ -308,67 +286,47 @@ type AsyncType() = } let cts = new CancellationTokenSource() let token = cts.Token -#if !NET46 - let t = -#else - use t = -#endif - Async.StartAsTask(a, cancellationToken=token) + use t = Async.StartAsTask(a, cancellationToken=token) // printfn "%A" t.Status ewh.WaitOne() |> Assert.True cts.Cancel() // printfn "%A" t.Status let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (exceptionThrown) Assert.True(t.IsCanceled) Assert.True(!cancelled) [] - member this.CreateImmediateAsTask () = + member _.CreateImmediateAsTask () = let s = "Hello tasks!" let a = async { return s } -#if !NET46 - let t : Task = -#else - use t : Task = -#endif - Async.StartImmediateAsTask a - this.WaitASec t + use t : Task = Async.StartImmediateAsTask a + waitASec t Assert.True (t.IsCompleted) Assert.AreEqual(s, t.Result) [] - member this.StartImmediateAsTask () = + member _.StartImmediateAsTask () = let s = "Hello tasks!" let a = async { return s } -#if !NET46 - let t = -#else - use t = -#endif - Async.StartImmediateAsTask a - this.WaitASec t + use t = Async.StartImmediateAsTask a + waitASec t Assert.True (t.IsCompleted) Assert.AreEqual(s, t.Result) [] - member this.ExceptionPropagatesToImmediateTask () = + member _.ExceptionPropagatesToImmediateTask () = let a = async { do raise (Exception ()) } -#if !NET46 - let t = -#else - use t = -#endif - Async.StartImmediateAsTask a + use t = Async.StartImmediateAsTask a let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (t.IsFaulted) @@ -377,20 +335,15 @@ type AsyncType() = #if IGNORED [] [] - member this.CancellationPropagatesToImmediateTask () = + member _.CancellationPropagatesToImmediateTask () = let a = async { while true do () } -#if !NET46 - let t = -#else - use t = -#endif - Async.StartImmediateAsTask a + use t = Async.StartImmediateAsTask a Async.CancelDefaultToken () let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (exceptionThrown) Assert.True(t.IsCanceled) @@ -399,7 +352,7 @@ type AsyncType() = #if IGNORED [] [] - member this.CancellationPropagatesToGroupImmediate () = + member _.CancellationPropagatesToGroupImmediate () = let ewh = new ManualResetEvent(false) let cancelled = ref false let a = async { @@ -417,7 +370,7 @@ type AsyncType() = // printfn "%A" t.Status let mutable exceptionThrown = false try - this.WaitASec t + waitASec t with e -> exceptionThrown <- true Assert.True (exceptionThrown) Assert.True(t.IsCanceled) @@ -425,14 +378,9 @@ type AsyncType() = #endif [] - member this.TaskAsyncValue () = + member _.TaskAsyncValue () = let s = "Test" -#if !NET46 - let t = -#else - use t = -#endif - Task.Factory.StartNew(Func<_>(fun () -> s)) + use t = Task.Factory.StartNew(Func<_>(fun () -> s)) let a = async { let! s1 = Async.AwaitTask(t) return s = s1 @@ -440,7 +388,7 @@ type AsyncType() = Async.RunSynchronously(a) |> Assert.True [] - member this.AwaitTaskCancellation () = + member _.AwaitTaskCancellation () = let test() = async { let tcs = new System.Threading.Tasks.TaskCompletionSource() tcs.SetCanceled() @@ -453,7 +401,7 @@ type AsyncType() = Async.RunSynchronously(test()) |> Assert.True [] - member this.AwaitCompletedTask() = + member _.AwaitCompletedTask() = let test() = async { let threadIdBefore = Thread.CurrentThread.ManagedThreadId do! Async.AwaitTask Task.CompletedTask @@ -464,7 +412,7 @@ type AsyncType() = Async.RunSynchronously(test()) |> Assert.True [] - member this.AwaitTaskCancellationUntyped () = + member _.AwaitTaskCancellationUntyped () = let test() = async { let tcs = new System.Threading.Tasks.TaskCompletionSource() tcs.SetCanceled() @@ -477,13 +425,8 @@ type AsyncType() = Async.RunSynchronously(test()) |> Assert.True [] - member this.TaskAsyncValueException () = -#if !NET46 - let t = -#else - use t = -#endif - Task.Factory.StartNew(Func(fun () -> raise <| Exception())) + member _.TaskAsyncValueException () = + use t = Task.Factory.StartNew(Func(fun () -> raise <| Exception())) let a = async { try let! v = Async.AwaitTask(t) @@ -494,16 +437,11 @@ type AsyncType() = // test is flaky: https://github.com/dotnet/fsharp/issues/11586 //[] - member this.TaskAsyncValueCancellation () = + member _.TaskAsyncValueCancellation () = use ewh = new ManualResetEvent(false) let cts = new CancellationTokenSource() let token = cts.Token -#if !NET46 - let t : Task= -#else - use t : Task= -#endif - Task.Factory.StartNew(Func(fun () -> while not token.IsCancellationRequested do ()), token) + use t : Task = Task.Factory.StartNew(Func(fun () -> while not token.IsCancellationRequested do ()), token) let cancelled = ref true let a = async { @@ -521,14 +459,9 @@ type AsyncType() = ewh.WaitOne(10000) |> ignore [] - member this.NonGenericTaskAsyncValue () = + member _.NonGenericTaskAsyncValue () = let hasBeenCalled = ref false -#if !NET46 - let t = -#else - use t = -#endif - Task.Factory.StartNew(Action(fun () -> hasBeenCalled := true)) + use t = Task.Factory.StartNew(Action(fun () -> hasBeenCalled := true)) let a = async { do! Async.AwaitTask(t) return true @@ -537,13 +470,8 @@ type AsyncType() = (!hasBeenCalled && result) |> Assert.True [] - member this.NonGenericTaskAsyncValueException () = -#if !NET46 - let t = -#else - use t = -#endif - Task.Factory.StartNew(Action(fun () -> raise <| Exception())) + member _.NonGenericTaskAsyncValueException () = + use t = Task.Factory.StartNew(Action(fun () -> raise <| Exception())) let a = async { try let! v = Async.AwaitTask(t) @@ -553,16 +481,11 @@ type AsyncType() = Async.RunSynchronously(a) |> Assert.True [] - member this.NonGenericTaskAsyncValueCancellation () = + member _.NonGenericTaskAsyncValueCancellation () = use ewh = new ManualResetEvent(false) let cts = new CancellationTokenSource() let token = cts.Token -#if !NET46 - let t = -#else - use t = -#endif - Task.Factory.StartNew(Action(fun () -> while not token.IsCancellationRequested do ()), token) + use t = Task.Factory.StartNew(Action(fun () -> while not token.IsCancellationRequested do ()), token) let a = async { try @@ -579,7 +502,7 @@ type AsyncType() = ewh.WaitOne(10000) |> ignore [] - member this.CancellationExceptionThrown () = + member _.CancellationExceptionThrown () = use ewh = new ManualResetEventSlim(false) let cts = new CancellationTokenSource() let token = cts.Token @@ -594,3 +517,20 @@ type AsyncType() = cts.Cancel() ewh.Wait(10000) |> ignore Assert.False hasThrown + + [] + member _.NoStackOverflowOnRecursion() = + + let mutable hasThrown = false + let rec loop (x: int) = async { + do! Task.CompletedTask |> Async.AwaitTask + Console.WriteLine (if x = 10000 then failwith "finish" else x) + return! loop(x+1) + } + + try + Async.RunSynchronously (loop 0) + hasThrown <- false + with Failure "finish" -> + hasThrown <- true + Assert.True hasThrown From afee7f2614f8765ac860ea62a8792684c8becc79 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 15:24:53 +0100 Subject: [PATCH 2/9] fix 11797 --- src/fsharp/FSharp.Core/async.fs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index f8037207c76..ee5d4912945 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -933,27 +933,28 @@ namespace Microsoft.FSharp.Control ctxt.cont () // Helper to attach continuation to the given task, which is assumed not to be completed. - // When the task completes the continuation will be run asynchronously in the thread pool - // with trampoline protection. + // When the task completes the continuation will be run synchronously on the thread + // completing the task. This will install a new trampoline on that thread and continue the + // execution of the async there. [] let AttachContinuationToTask (task: Task<'T>) (ctxt: AsyncActivation<'T>) = task.ContinueWith(Action>(fun completedTask -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> OnTaskCompleted completedTask ctxt) - |> unfake)) + |> unfake), TaskContinuationOptions.ExecuteSynchronously) |> ignore |> fake // Helper to attach continuation to the given task, which is assumed not to be completed - // When the task completes the continuation will be run asynchronously in the thread pool - // with trampoline protection. + // When the task completes the continuation will be run synchronously on the thread + // completing the task. This will install a new trampoline on that thread and continue the + // execution of the async there. [] let AttachContinuationToUnitTask (task: Task) (ctxt: AsyncActivation) = task.ContinueWith(Action(fun completedTask -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> OnUnitTaskCompleted completedTask ctxt) - |> unfake - )) + |> unfake), TaskContinuationOptions.ExecuteSynchronously) |> ignore |> fake From 0d1c59de2466782ed73732a737f9ffc792bf1a06 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 15:31:58 +0100 Subject: [PATCH 3/9] fix 11797 --- src/fsharp/FSharp.Core/async.fs | 96 ++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 37 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index ee5d4912945..23cbf78c0e5 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -237,41 +237,41 @@ namespace Microsoft.FSharp.Control member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } /// Produce a new execution context for a composite async - member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } + member ctxt.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } /// Produce a new execution context for a composite async - member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } + member ctxt.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } /// Produce a new execution context for a composite async member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } /// The extra information relevant to the execution of the async - member _.aux = contents.aux + member ctxt.aux = contents.aux /// The success continuation relevant to the execution of the async - member _.cont = contents.cont + member ctxt.cont = contents.cont /// The exception continuation relevant to the execution of the async - member _.econt = contents.aux.econt + member ctxt.econt = contents.aux.econt /// The cancellation continuation relevant to the execution of the async - member _.ccont = contents.aux.ccont + member ctxt.ccont = contents.aux.ccont /// The cancellation token relevant to the execution of the async - member _.token = contents.aux.token + member ctxt.token = contents.aux.token /// The trampoline holder being used to protect execution of the async - member _.trampolineHolder = contents.aux.trampolineHolder + member ctxt.trampolineHolder = contents.aux.trampolineHolder /// Check if cancellation has been requested - member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested + member ctxt.IsCancellationRequested = contents.aux.token.IsCancellationRequested /// Call the cancellation continuation of the active computation - member _.OnCancellation () = + member ctxt.OnCancellation () = contents.aux.ccont (OperationCanceledException (contents.aux.token)) /// Check for trampoline hijacking. - member inline _.HijackCheckThenCall cont arg = + member inline ctxt.HijackCheckThenCall cont arg = contents.aux.trampolineHolder.HijackCheckThenCall cont arg /// Call the success continuation of the asynchronous execution context after checking for @@ -283,7 +283,7 @@ namespace Microsoft.FSharp.Control ctxt.HijackCheckThenCall ctxt.cont result /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member _.OnExceptionRaised() = + member ctxt.OnExceptionRaised() = contents.aux.trampolineHolder.OnExceptionRaised contents.aux.econt /// Make an initial async activation. @@ -394,6 +394,24 @@ namespace Microsoft.FSharp.Control else fake() + /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) + [] + let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) userCode result1 = + let mutable res = Unchecked.defaultof<_> + let mutable ok = false + + try + res <- userCode result1 + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + res.Invoke ctxt + else + fake() + /// Apply 'catchFilter' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' /// then send 'result1' to the exception continuation. [] @@ -441,30 +459,31 @@ namespace Microsoft.FSharp.Control [] // Note: direct calls to this function end up in user assemblies via inlining let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = - // We do a cancellation check before the Bind, but not after. This is because we may be about to enter - // a TryFinally if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvoke ctxt result1 part2)) + Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt part2 result1 )) [] /// Re-route all continuations to execute the finally function. let TryFinally (ctxt: AsyncActivation<'T>) computation finallyFunction = - // The new continuation runs the finallyFunction and resumes the old continuation - // If an exception is thrown we continue with the previous exception continuation. - let cont result = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) - // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. - // If an exception is thrown we continue with the previous exception continuation. - let econt exn = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt exn)) - // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. - // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) - let ccont cexn = - CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) - let newCtxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) - computation.Invoke newCtxt + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + // The new continuation runs the finallyFunction and resumes the old continuation + // If an exception is thrown we continue with the previous exception continuation. + let cont result = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) + // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. + // If an exception is thrown we continue with the previous exception continuation. + let econt exn = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt exn)) + // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. + // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) + let ccont cexn = + CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + let newCtxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) + computation.Invoke newCtxt /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. /// If it returns Some, invoke the resulting async. @@ -487,7 +506,7 @@ namespace Microsoft.FSharp.Control let CreateProtectedAsync f = MakeAsync (fun ctxt -> ProtectedCode ctxt f) - /// Make an async from an AsyncResult + /// Internal way of making an async from result, for exact code compat. let CreateAsyncResultAsync res = MakeAsync (fun ctxt -> match res with @@ -606,8 +625,7 @@ namespace Microsoft.FSharp.Control ccont = (fun x -> ctxt.trampolineHolder.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont x))) // When run, ensures that each of the continuations of the process are run in the same synchronization context. - // Also protects 'f' which should not actually call any of the continuations of 'ctxt' - let CreateDelimitedProtectedAsync f = + let CreateDelimitedUserCodeAsync f = CreateProtectedAsync (fun ctxt -> let ctxtWithSync = DelimitSyncContext ctxt f ctxtWithSync) @@ -1354,7 +1372,7 @@ namespace Microsoft.FSharp.Control AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore static member Sleep (millisecondsDueTime: int64) : Async = - CreateDelimitedProtectedAsync (fun ctxt -> + CreateDelimitedUserCodeAsync (fun ctxt -> let mutable timer = None: Timer option let cont = ctxt.cont let ccont = ctxt.ccont @@ -1415,7 +1433,7 @@ namespace Microsoft.FSharp.Control let ok = waitHandle.WaitOne(0, exitContext=false) async.Return ok) else - CreateDelimitedProtectedAsync(fun ctxt -> + CreateDelimitedUserCodeAsync(fun ctxt -> let aux = ctxt.aux let rwh = ref (None: RegisteredWaitHandle option) let latch = Latch() @@ -1464,7 +1482,11 @@ namespace Microsoft.FSharp.Control /// Bind the result of a result cell, calling the appropriate continuation. static member BindResult (result: AsyncResult<'T>) : Async<'T> = - CreateAsyncResultAsync result + MakeAsync (fun ctxt -> + (match result with + | Ok v -> ctxt.cont v + | Error exn -> ctxt.econt exn + | Canceled exn -> ctxt.ccont exn) ) /// Await and use the result of a result cell. The resulting async doesn't support cancellation /// or timeout directly, rather the underlying computation must fill the result if cancellation @@ -1687,13 +1709,13 @@ namespace Microsoft.FSharp.Control if task.IsCompleted then MakeAsync (fun ctxt -> OnTaskCompleted task ctxt) else - CreateDelimitedProtectedAsync (fun ctxt -> AttachContinuationToTask task ctxt) + CreateDelimitedUserCodeAsync (fun ctxt -> AttachContinuationToTask task ctxt) static member AwaitTask (task:Task) : Async = if task.IsCompleted then MakeAsync (fun ctxt -> OnUnitTaskCompleted task ctxt) else - CreateDelimitedProtectedAsync (fun ctxt -> AttachContinuationToUnitTask task ctxt) + CreateDelimitedUserCodeAsync (fun ctxt -> AttachContinuationToUnitTask task ctxt) module CommonExtensions = From 0293058945d48ed6fe07fd7054ed53c7be727d4a Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 20:13:34 +0100 Subject: [PATCH 4/9] cleanup async.fs --- src/fsharp/FSharp.Core/async.fs | 1031 +++++++++-------- .../Microsoft.FSharp.Control/AsyncModule.fs | 4 +- 2 files changed, 572 insertions(+), 463 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index 23cbf78c0e5..ae2d1ffd315 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -23,11 +23,11 @@ namespace Microsoft.FSharp.Control let linkedCTS = CancellationTokenSource.CreateLinkedTokenSource(cancellationToken, failureCTS.Token) - member this.Token = linkedCTS.Token + member _.Token = linkedCTS.Token - member this.Cancel() = failureCTS.Cancel() + member _.Cancel() = failureCTS.Cancel() - member this.Dispose() = + member _.Dispose() = linkedCTS.Dispose() failureCTS.Dispose() @@ -112,7 +112,9 @@ namespace Microsoft.FSharp.Control with exn -> match storedExnCont with | None -> - reraise() + // Note, the exception escapes the trampoline. This should not happen since all + // exception-generating code shuld use ProtectCode. + reraise() | Some econt -> storedExnCont <- None let edi = ExceptionDispatchInfo.RestoreOrCapture exn @@ -168,11 +170,11 @@ namespace Microsoft.FSharp.Control trampoline <- Trampoline() trampoline.Execute firstAction - member this.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + member _.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = syncCtxt.Post (sendOrPostCallbackWithTrampoline, state=(f |> box)) AsyncReturn.Fake() - member this.QueueWorkItemWithTrampoline (f: unit -> AsyncReturn) = + member _.QueueWorkItemWithTrampoline (f: unit -> AsyncReturn) = if not (ThreadPool.QueueUserWorkItem(waitCallbackForQueueWorkItemWithTrampoline, f |> box)) then failwith "failed to queue user work item" AsyncReturn.Fake() @@ -237,45 +239,47 @@ namespace Microsoft.FSharp.Control member ctxt.WithExceptionContinuation econt = AsyncActivation<'T> { contents with aux = { ctxt.aux with econt = econt } } /// Produce a new execution context for a composite async - member ctxt.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } + member _.WithContinuation cont = AsyncActivation<'U> { cont = cont; aux = contents.aux } /// Produce a new execution context for a composite async - member ctxt.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } + member _.WithContinuations(cont, econt) = AsyncActivation<'U> { cont = cont; aux = { contents.aux with econt = econt } } /// Produce a new execution context for a composite async member ctxt.WithContinuations(cont, econt, ccont) = AsyncActivation<'T> { contents with cont = cont; aux = { ctxt.aux with econt = econt; ccont = ccont } } /// The extra information relevant to the execution of the async - member ctxt.aux = contents.aux + member _.aux = contents.aux /// The success continuation relevant to the execution of the async - member ctxt.cont = contents.cont + member _.cont = contents.cont /// The exception continuation relevant to the execution of the async - member ctxt.econt = contents.aux.econt + member _.econt = contents.aux.econt /// The cancellation continuation relevant to the execution of the async - member ctxt.ccont = contents.aux.ccont + member _.ccont = contents.aux.ccont /// The cancellation token relevant to the execution of the async - member ctxt.token = contents.aux.token + member _.token = contents.aux.token /// The trampoline holder being used to protect execution of the async - member ctxt.trampolineHolder = contents.aux.trampolineHolder + member _.trampolineHolder = contents.aux.trampolineHolder /// Check if cancellation has been requested - member ctxt.IsCancellationRequested = contents.aux.token.IsCancellationRequested + member _.IsCancellationRequested = contents.aux.token.IsCancellationRequested /// Call the cancellation continuation of the active computation - member ctxt.OnCancellation () = + member _.OnCancellation () = contents.aux.ccont (OperationCanceledException (contents.aux.token)) /// Check for trampoline hijacking. - member inline ctxt.HijackCheckThenCall cont arg = + member inline _.HijackCheckThenCall cont arg = contents.aux.trampolineHolder.HijackCheckThenCall cont arg /// Call the success continuation of the asynchronous execution context after checking for /// cancellation and trampoline hijacking. + // - Cancellation check + // - Hijack check member ctxt.OnSuccess result = if ctxt.IsCancellationRequested then ctxt.OnCancellation () @@ -283,7 +287,7 @@ namespace Microsoft.FSharp.Control ctxt.HijackCheckThenCall ctxt.cont result /// Save the exception continuation during propagation of an exception, or prior to raising an exception - member ctxt.OnExceptionRaised() = + member _.OnExceptionRaised() = contents.aux.trampolineHolder.OnExceptionRaised contents.aux.econt /// Make an initial async activation. @@ -293,8 +297,28 @@ namespace Microsoft.FSharp.Control /// Queue the success continuation of the asynchronous execution context as a work item in the thread pool /// after installing a trampoline member ctxt.QueueContinuationWithTrampoline (result: 'T) = - let ctxt = ctxt - ctxt.aux.trampolineHolder.QueueWorkItemWithTrampoline(fun () -> ctxt.cont result) + let cont = ctxt.cont + ctxt.aux.trampolineHolder.QueueWorkItemWithTrampoline(fun () -> cont result) + + /// Ensure that any exceptions raised by the immediate execution of "userCode" + /// are sent to the exception continuation. This is done by allowing the exception to propagate + /// to the trampoline, and the saved exception continuation is called there. + /// + /// It is also valid for MakeAsync primitive code to call the exception continuation directly. + [] + member ctxt.ProtectCode userCode = + let mutable ok = false + try + let res = userCode() + ok <- true + res + finally + if not ok then + ctxt.OnExceptionRaised() + + member ctxt.PostWithTrampoline (syncCtxt: SynchronizationContext) (f: unit -> AsyncReturn) = + let holder = contents.aux.trampolineHolder + ctxt.ProtectCode (fun () -> holder.PostWithTrampoline syncCtxt f) /// Call the success continuation of the asynchronous execution context member ctxt.CallContinuation(result: 'T) = @@ -311,17 +335,7 @@ namespace Microsoft.FSharp.Control let mutable i = 0 /// Execute the latch - member this.Enter() = Interlocked.CompareExchange(&i, 1, 0) = 0 - - /// Ensures that a function is only called once - [] - type Once() = - let latch = Latch() - - /// Execute the function at most once - member this.Do f = - if latch.Enter() then - f() + member _.Enter() = Interlocked.CompareExchange(&i, 1, 0) = 0 /// Represents the result of an asynchronous computation [] @@ -355,8 +369,11 @@ namespace Microsoft.FSharp.Control let Invoke (computation: Async<'T>) (ctxt: AsyncActivation<_>) : AsyncReturn = ctxt.HijackCheckThenCall computation.Invoke ctxt - /// Apply userCode to x. If no exception is raised then call the normal continuation. Used to implement + /// Apply 'userCode' to 'arg'. If no exception is raised then call the normal continuation. Used to implement /// 'finally' and 'when cancelled'. + /// + /// - Apply 'userCode' to argument with exception protection + /// - Hijack check before invoking the continuation [] let CallThenContinue userCode arg (ctxt: AsyncActivation<_>) : AsyncReturn = let mutable result = Unchecked.defaultof<_> @@ -375,8 +392,11 @@ namespace Microsoft.FSharp.Control fake() /// Apply 'part2' to 'result1' and invoke the resulting computation. - // - // Note: direct calls to this function end up in user assemblies via inlining + /// + /// Note: direct calls to this function end up in user assemblies via inlining + /// + /// - Apply 'part2' to argument with exception protection + /// - Hijack check before invoking the resulting computation [] let CallThenInvoke (ctxt: AsyncActivation<_>) result1 part2 : AsyncReturn = let mutable result = Unchecked.defaultof<_> @@ -394,33 +414,18 @@ namespace Microsoft.FSharp.Control else fake() - /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) - [] - let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) userCode result1 = - let mutable res = Unchecked.defaultof<_> - let mutable ok = false - - try - res <- userCode result1 - ok <- true - finally - if not ok then - ctxt.OnExceptionRaised() - - if ok then - res.Invoke ctxt - else - fake() - - /// Apply 'catchFilter' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' + /// Apply 'filterFunction' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' /// then send 'result1' to the exception continuation. + /// + /// - Apply 'filterFunction' to argument with exception protection + /// - Hijack check before invoking the resulting computation or exception continuation [] - let CallFilterThenInvoke (ctxt: AsyncActivation<'T>) catchFilter (edi: ExceptionDispatchInfo) : AsyncReturn = - let mutable resOpt = Unchecked.defaultof<_> + let CallFilterThenInvoke (ctxt: AsyncActivation<'T>) filterFunction (edi: ExceptionDispatchInfo) : AsyncReturn = + let mutable resOpt = None let mutable ok = false try - resOpt <- catchFilter (edi.GetAssociatedSourceException()) + resOpt <- filterFunction (edi.GetAssociatedSourceException()) ok <- true finally if not ok then @@ -435,200 +440,268 @@ namespace Microsoft.FSharp.Control else fake() - /// Internal way of making an async from code, for exact code compat. - /// Perform a cancellation check and ensure that any exceptions raised by - /// the immediate execution of "userCode" are sent to the exception continuation. - [] - let ProtectedCode (ctxt: AsyncActivation<'T>) userCode = - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - let mutable ok = false - try - let res = userCode ctxt - ok <- true - res - finally - if not ok then - ctxt.OnExceptionRaised() - /// Build a primitive without any exception or resync protection [] let MakeAsync body = { Invoke = body } [] - // Note: direct calls to this function end up in user assemblies via inlining + let MakeAsyncWithCancelCheck body = + MakeAsync (fun ctxt -> + if ctxt.IsCancellationRequested then + ctxt.OnCancellation () + else + body ctxt) + + /// Execute part1, then apply part2, then execute the result of that + /// + /// Note: direct calls to this function end up in user assemblies via inlining + /// - Initial cancellation check + /// - Initial hijack check (see Invoke) + /// - Hijack check after applying 'part2' to argument (see CallThenInvoke) + /// - No cancellation check after applying 'part2' to argument (see CallThenInvoke) + /// - Apply 'part2' to argument with exception protection (see CallThenInvoke) + [] let Bind (ctxt: AsyncActivation<'T>) (part1: Async<'U>) (part2: 'U -> Async<'T>) : AsyncReturn = if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt part2 result1 )) + // Note, no cancellation check is done before calling 'part2'. This is + // because part1 may bind a resource, while part2 is a try/finally, and, if + // the resource creation completes, we want to enter part2 before cancellation takes effect. + Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvoke ctxt result1 part2)) - [] /// Re-route all continuations to execute the finally function. + /// - Cancellation check after 'entering' the try/finally and before running the body + /// - Hijack check after 'entering' the try/finally and before running the body (see Invoke) + /// - Run 'finallyFunction' with exception protection (see CallThenContinue) + /// - Hijack check before any of the continuations (see CallThenContinue) + [] let TryFinally (ctxt: AsyncActivation<'T>) computation finallyFunction = + // Note, we don't test for cancellation before entering a try/finally. This prevents + // a resource being created without being disposed. + + // The new continuation runs the finallyFunction and resumes the old continuation + // If an exception is thrown we continue with the previous exception continuation. + let cont result = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) + + // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. + // If an exception is thrown we continue with the previous exception continuation. + let econt edi = + CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt edi)) + + // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. + // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) + let ccont cexn = + CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) + + let ctxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - // The new continuation runs the finallyFunction and resumes the old continuation - // If an exception is thrown we continue with the previous exception continuation. - let cont result = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.cont result)) - // The new exception continuation runs the finallyFunction and then runs the previous exception continuation. - // If an exception is thrown we continue with the previous exception continuation. - let econt exn = - CallThenContinue finallyFunction () (ctxt.WithContinuation(fun () -> ctxt.econt exn)) - // The cancellation continuation runs the finallyFunction and then runs the previous cancellation continuation. - // If an exception is thrown we continue with the previous cancellation continuation (the exception is lost) - let ccont cexn = - CallThenContinue finallyFunction () (ctxt.WithContinuations(cont=(fun () -> ctxt.ccont cexn), econt = (fun _ -> ctxt.ccont cexn))) - let newCtxt = ctxt.WithContinuations(cont=cont, econt=econt, ccont=ccont) - computation.Invoke newCtxt + Invoke computation ctxt /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. /// If it returns Some, invoke the resulting async. + /// - Cancellation check before entering the try + /// - Hijack check after 'entering' the try/with + /// - Cancellation check before applying the 'catchFunction' + /// - Apply `catchFunction' to argument with exception protection (see CallFilterThenInvoke) + /// - Hijack check before invoking the resulting computation or exception continuation [] let TryWith (ctxt: AsyncActivation<'T>) computation catchFunction = if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - let newCtxt = + let ctxt = ctxt.WithExceptionContinuation(fun edi -> if ctxt.IsCancellationRequested then ctxt.OnCancellation () else CallFilterThenInvoke ctxt catchFunction edi) - computation.Invoke newCtxt - /// Internal way of making an async from code, for exact code compat. - /// When run, ensures that any exceptions raised by the immediate execution of "f" are - /// sent to the exception continuation. - let CreateProtectedAsync f = - MakeAsync (fun ctxt -> ProtectedCode ctxt f) + Invoke computation ctxt - /// Internal way of making an async from result, for exact code compat. + /// Make an async for an AsyncResult + // - No cancellation check + // - No hijack check let CreateAsyncResultAsync res = MakeAsync (fun ctxt -> match res with | AsyncResult.Ok r -> ctxt.cont r | AsyncResult.Error edi -> ctxt.econt edi - | AsyncResult.Canceled oce -> ctxt.ccont oce) + | AsyncResult.Canceled cexn -> ctxt.ccont cexn) - // Generate async computation which calls its continuation with the given result + /// Generate async computation which calls its continuation with the given result + /// - Cancellation check (see OnSuccess) + /// - Hijack check (see OnSuccess) let inline CreateReturnAsync res = // Note: this code ends up in user assemblies via inlining MakeAsync (fun ctxt -> ctxt.OnSuccess res) - // The primitive bind operation. Generate a process that runs the first process, takes - // its result, applies f and then runs the new process produced. Hijack if necessary and - // run 'f' with exception protection + /// Runs the first process, takes its result, applies f and then runs the new process produced. + /// - Initial cancellation check (see Bind) + /// - Initial hijack check (see Bind) + /// - Hijack check after applying 'part2' to argument (see Bind) + /// - No cancellation check after applying 'part2' to argument (see Bind) + /// - Apply 'part2' to argument with exception protection (see Bind) let inline CreateBindAsync part1 part2 = // Note: this code ends up in user assemblies via inlining MakeAsync (fun ctxt -> Bind ctxt part1 part2) - // Call the given function with exception protection, but first - // check for cancellation. + /// Call the given function with exception protection. + /// - No initial cancellation check + /// - Hijack check after applying part2 to argument (see CallThenInvoke) let inline CreateCallAsync part2 result1 = // Note: this code ends up in user assemblies via inlining MakeAsync (fun ctxt -> - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - CallThenInvoke ctxt result1 part2) + CallThenInvoke ctxt result1 part2) + /// Call the given function with exception protection. + /// - Initial cancellation check + /// - Hijack check after applying computation to argument (see CallThenInvoke) + /// - Apply 'computation' to argument with exception protection (see CallThenInvoke) let inline CreateDelayAsync computation = // Note: this code ends up in user assemblies via inlining - CreateCallAsync computation () + MakeAsyncWithCancelCheck (fun ctxt -> + CallThenInvoke ctxt () computation) /// Implements the sequencing construct of async computation expressions + /// - Initial cancellation check (see CreateBindAsync) + /// - Initial hijack check (see CreateBindAsync) + /// - Hijack check after applying 'part2' to argument (see CreateBindAsync) + /// - No cancellation check after applying 'part2' to argument (see CreateBindAsync) + /// - Apply 'part2' to argument with exception protection (see CreateBindAsync) let inline CreateSequentialAsync part1 part2 = // Note: this code ends up in user assemblies via inlining CreateBindAsync part1 (fun () -> part2) /// Create an async for a try/finally + /// - Cancellation check after 'entering' the try/finally and before running the body + /// - Hijack check after 'entering' the try/finally and before running the body (see TryFinally) + /// - Apply 'finallyFunction' with exception protection (see TryFinally) let inline CreateTryFinallyAsync finallyFunction computation = MakeAsync (fun ctxt -> TryFinally ctxt computation finallyFunction) /// Create an async for a try/with filtering exceptions through a pattern match - let inline CreateTryWithFilterAsync catchFunction computation = - MakeAsync (fun ctxt -> TryWith ctxt computation (fun edi -> catchFunction edi)) + /// - Cancellation check before entering the try (see TryWith) + /// - Cancellation check before entering the with (see TryWith) + /// - Apply `filterFunction' to argument with exception protection (see TryWith) + /// - Hijack check before invoking the resulting computation or exception continuation + let inline CreateTryWithFilterAsync filterFunction computation = + MakeAsync (fun ctxt -> TryWith ctxt computation filterFunction) /// Create an async for a try/with filtering + /// - Cancellation check before entering the try (see TryWith) + /// - Cancellation check before entering the with (see TryWith) + /// - Apply `catchFunction' to argument with exception protection (see TryWith) + /// - Hijack check before invoking the resulting computation or exception continuation let inline CreateTryWithAsync catchFunction computation = - CreateTryWithFilterAsync (fun exn -> Some (catchFunction exn)) computation + MakeAsync (fun ctxt -> TryWith ctxt computation (fun exn -> Some (catchFunction exn))) /// Call the finallyFunction if the computation results in a cancellation, and then continue with cancellation. /// If the finally function gives an exception then continue with cancellation regardless. + /// - No cancellation check before entering the when-cancelled + /// - No hijack check before entering the when-cancelled + /// - Apply `finallyFunction' to argument with exception protection (see CallThenContinue) + /// - Hijack check before continuing with cancellation (see CallThenContinue) let CreateWhenCancelledAsync (finallyFunction: OperationCanceledException -> unit) computation = MakeAsync (fun ctxt -> let ccont = ctxt.ccont - let newCtxt = - ctxt.WithCancellationContinuation(fun exn -> - CallThenContinue finallyFunction exn (ctxt.WithContinuations(cont = (fun _ -> ccont exn), econt = (fun _ -> ccont exn)))) - computation.Invoke newCtxt) + let ctxt = + ctxt.WithCancellationContinuation(fun cexn -> + CallThenContinue finallyFunction cexn (ctxt.WithContinuations(cont = (fun _ -> ccont cexn), econt = (fun _ -> ccont cexn)))) + computation.Invoke ctxt) /// A single pre-allocated computation that fetched the current cancellation token let cancellationTokenAsync = MakeAsync (fun ctxt -> ctxt.cont ctxt.aux.token) /// A single pre-allocated computation that returns a unit result + /// - Cancellation check (see CreateReturnAsync) + /// - Hijack check (see CreateReturnAsync) let unitAsync = CreateReturnAsync() /// Implement use/Dispose + /// + /// - No initial cancellation check before applying computation to its argument. See CreateTryFinallyAsync + /// and CreateCallAsync. We enter the try/finally before any cancel checks. + /// - Cancellation check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) + /// - Hijack check after 'entering' the implied try/finally and before running the body (see CreateTryFinallyAsync) + /// - Run 'disposeFunction' with exception protection (see CreateTryFinallyAsync) let CreateUsingAsync (resource:'T :> IDisposable) (computation:'T -> Async<'a>) : Async<'a> = - let mutable x = 0 - let disposeFunction _ = - if Interlocked.CompareExchange(&x, 1, 0) = 0 then - Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource - CreateTryFinallyAsync disposeFunction (CreateCallAsync computation resource) |> CreateWhenCancelledAsync disposeFunction + let disposeFunction () = Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource + CreateTryFinallyAsync disposeFunction (CreateCallAsync computation resource) + /// - Initial cancellation check (see CreateBindAsync) + /// - Initial hijack check (see CreateBindAsync) + /// - Cancellation check after (see unitAsync) + /// - Hijack check after (see unitAsync) let inline CreateIgnoreAsync computation = CreateBindAsync computation (fun _ -> unitAsync) /// Implement the while loop construct of async computation expressions + /// - Initial cancellation check before initial execution of guard + /// - Initial hijack check before initial execution of guard + /// - Cancellation check before each execution of the body (see CreateSequentialAsync) + /// - Hijack check before each execution of the body (see CreateSequentialAsync) + /// - Hijack check after each execution of the body and before guard (see CreateSequentialAsync) + /// - No cancellation check after each execution of body and before guard (see CreateSequentialAsync) + /// - Cancellation check after guard fails (see unitAsync) + /// - Hijack check after guard fails (see unitAsync) + /// - Apply 'guardFunc' with exception protection let CreateWhileAsync guardFunc computation = - if guardFunc() then - let mutable whileAsync = Unchecked.defaultof<_> - whileAsync <- CreateBindAsync computation (fun () -> if guardFunc() then whileAsync else unitAsync) - whileAsync - else - unitAsync + let mutable whileAsync = Unchecked.defaultof<_> + whileAsync <- CreateDelayAsync (fun () -> if guardFunc() then CreateSequentialAsync computation whileAsync else unitAsync) + whileAsync /// Implement the for loop construct of async commputation expressions + /// - No initial cancellation check before GetEnumerator call. + /// - No initial cancellation check before entering protection of implied try/finally + /// - Cancellation check after 'entering' the implied try/finally and before loop + /// - Hijack check after 'entering' the implied try/finally and before loop + /// - Once not apply 'GetEnumerator' with exception protection. However for an 'async' + /// in an 'async { ... }' the exception protection will be provided by the enclosing + // Delay or Bind or similar construct. + /// - Apply 'MoveNext' with exception protection + /// - Apply 'Current' with exception protection let CreateForLoopAsync (source: seq<_>) computation = CreateUsingAsync (source.GetEnumerator()) (fun ie -> CreateWhileAsync (fun () -> ie.MoveNext()) (CreateDelayAsync (fun () -> computation ie.Current))) + /// - Initial cancellation check + /// - Call syncCtxt.Post with exception protection. THis may fail as it is arbitrary user code let CreateSwitchToAsync (syncCtxt: SynchronizationContext) = - CreateProtectedAsync (fun ctxt -> - ctxt.trampolineHolder.PostWithTrampoline syncCtxt ctxt.cont) + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.PostWithTrampoline syncCtxt ctxt.cont) + /// - Initial cancellation check + /// - Create Thread and call Start() with exception protection. We don't expect this + /// to fail but protect nevertheless. let CreateSwitchToNewThreadAsync() = - CreateProtectedAsync (fun ctxt -> - ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont) + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.StartThreadWithTrampoline ctxt.cont)) + /// - Initial cancellation check + /// - Call ThreadPool.QueueUserWorkItem with exception protection. We don't expect this + /// to fail but protect nevertheless. let CreateSwitchToThreadPoolAsync() = - CreateProtectedAsync (fun ctxt -> - ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont) + MakeAsyncWithCancelCheck (fun ctxt -> + ctxt.ProtectCode (fun () -> ctxt.trampolineHolder.QueueWorkItemWithTrampoline ctxt.cont)) /// Post back to the sync context regardless of which continuation is taken + /// - Call syncCtxt.Post with exception protection let DelimitSyncContext (ctxt: AsyncActivation<_>) = match SynchronizationContext.Current with | null -> ctxt | syncCtxt -> - ctxt.WithContinuations(cont = (fun x -> ctxt.trampolineHolder.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), - econt = (fun x -> ctxt.trampolineHolder.PostWithTrampoline syncCtxt (fun () -> ctxt.econt x)), - ccont = (fun x -> ctxt.trampolineHolder.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont x))) - - // When run, ensures that each of the continuations of the process are run in the same synchronization context. - let CreateDelimitedUserCodeAsync f = - CreateProtectedAsync (fun ctxt -> - let ctxtWithSync = DelimitSyncContext ctxt - f ctxtWithSync) + ctxt.WithContinuations(cont = (fun x -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.cont x)), + econt = (fun edi -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.econt edi)), + ccont = (fun cexn -> ctxt.PostWithTrampoline syncCtxt (fun () -> ctxt.ccont cexn))) [] [] @@ -650,14 +723,15 @@ namespace Microsoft.FSharp.Control match syncCtxt, currentSyncCtxt with | null, null -> executeImmediately () - // See bug 370350; this logic is incorrect from the perspective of how SynchronizationContext is meant to work, - // but the logic works for mainline scenarios (WinForms/WPF/ASP.NET) and we won't change it again. + // This logic was added in F# 2.0 though is incorrect from the perspective of + // how SynchronizationContext is meant to work. However the logic works for + // mainline scenarios (WinForms/WPF) and for compatibility reasons we won't change it. | _ when Object.Equals(syncCtxt, currentSyncCtxt) && thread.Equals Thread.CurrentThread -> executeImmediately () | _ -> trampolineHolder.PostOrQueueWithTrampoline syncCtxt action - member _.ContinueWithPostOrQueue res = + member _.PostOrQueueWithTrampoline res = trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> ctxt.cont res) /// A utility type to provide a synchronization point between an asynchronous computation @@ -743,9 +817,9 @@ namespace Microsoft.FSharp.Control if reuseThread then cont.ContinueImmediate res else - cont.ContinueWithPostOrQueue res + cont.PostOrQueueWithTrampoline res | otherwise -> - otherwise |> List.iter (fun cont -> cont.ContinueWithPostOrQueue res |> unfake) |> fake + otherwise |> List.iter (fun cont -> cont.PostOrQueueWithTrampoline res |> unfake) |> fake member x.ResultAvailable = result.IsSome @@ -815,7 +889,7 @@ namespace Microsoft.FSharp.Control /// Run the asynchronous workflow and wait for its result. [] - let RunSynchronouslyInAnotherThread (token:CancellationToken, computation, timeout) = + let QueueAsyncAndWaitForResultSynchronously (token:CancellationToken) computation timeout = let token, innerCTS = // If timeout is provided, we govern the async by our own CTS, to cancel // when execution times out. Otherwise, the user-supplied token governs the async. @@ -827,12 +901,12 @@ namespace Microsoft.FSharp.Control use resultCell = new ResultCell>() QueueAsync - token - (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) - (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) - (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) - computation - |> unfake + token + (fun res -> resultCell.RegisterResult(AsyncResult.Ok res, reuseThread=true)) + (fun edi -> resultCell.RegisterResult(AsyncResult.Error edi, reuseThread=true)) + (fun exn -> resultCell.RegisterResult(AsyncResult.Canceled exn, reuseThread=true)) + computation + |> unfake let res = resultCell.TryWaitForResultSynchronously(?timeout = timeout) match res with @@ -851,7 +925,7 @@ namespace Microsoft.FSharp.Control res.Commit() [] - let RunSynchronouslyInCurrentThread (cancellationToken:CancellationToken, computation) = + let RunImmediate (cancellationToken:CancellationToken) computation = use resultCell = new ResultCell>() let trampolineHolder = TrampolineHolder() @@ -873,17 +947,8 @@ namespace Microsoft.FSharp.Control let RunSynchronously cancellationToken (computation: Async<'T>) timeout = // Reuse the current ThreadPool thread if possible. match Thread.CurrentThread.IsThreadPoolThread, timeout with - | true, None -> RunSynchronouslyInCurrentThread (cancellationToken, computation) - // When the timeout is given we need a dedicated thread - // which cancels the computation. - // Performing the cancellation in the ThreadPool eg. by using - // Timer from System.Threading or CancellationTokenSource.CancelAfter - // (which internally uses Timer) won't work properly - // when the ThreadPool is busy. - // - // And so when the timeout is given we always use the current thread - // for the cancellation and run the computation in another thread. - | _ -> RunSynchronouslyInAnotherThread (cancellationToken, computation, timeout) + | true, None -> RunImmediate cancellationToken computation + | _ -> QueueAsyncAndWaitForResultSynchronously cancellationToken computation timeout [] let Start cancellationToken (computation:Async) = @@ -976,6 +1041,34 @@ namespace Microsoft.FSharp.Control |> ignore |> fake + let DisposeRegistration (registration: byref) = + match registration with + | Some r -> + registration <- None + r.Dispose() + | None -> () + + let DisposeTimer (timer: byref) = + match timer with + | None -> () + | Some t -> + timer <- None + t.Dispose() + + let UnregisterWaitHandle (rwh: byref) = + match rwh with + | None -> () + | Some r -> + r.Unregister null |> ignore + rwh <- None + + let RemoveHandler (event: IEvent<_, _>) (del: byref<'Delegate option>) = + match del with + | Some d -> + del <- None + event.RemoveHandler d + | None -> () + [] type AsyncIAsyncResult<'T>(callback: System.AsyncCallback, state:obj) = // This gets set to false if the result is not available by the @@ -1031,9 +1124,9 @@ namespace Microsoft.FSharp.Control module AsBeginEndHelpers = let beginAction (computation, callback, state) = let aiar = new AsyncIAsyncResult<'T>(callback, state) - let cont v = aiar.SetResult (AsyncResult.Ok v) - let econt v = aiar.SetResult (AsyncResult.Error v) - let ccont v = aiar.SetResult (AsyncResult.Canceled v) + let cont res = aiar.SetResult (AsyncResult.Ok res) + let econt edi = aiar.SetResult (AsyncResult.Error edi) + let ccont cexn = aiar.SetResult (AsyncResult.Canceled cexn) StartWithContinuations aiar.Token computation cont econt ccont aiar.CheckForNotSynchronous() (aiar :> IAsyncResult) @@ -1097,47 +1190,40 @@ namespace Microsoft.FSharp.Control static member CancelCheck () = unitAsync static member FromContinuations (callback: ('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) : Async<'T> = - MakeAsync (fun ctxt -> - if ctxt.IsCancellationRequested then - ctxt.OnCancellation () - else - let mutable underCurrentThreadStack = true - let mutable contToTailCall = None - let thread = Thread.CurrentThread - let latch = Latch() - let once cont x = - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) - if Thread.CurrentThread.Equals thread && underCurrentThreadStack then - contToTailCall <- Some(fun () -> cont x) - else if Trampoline.ThisThreadHasTrampoline then - let syncCtxt = SynchronizationContext.Current - ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) |> unfake - else - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont x ) |> unfake - try - callback (once ctxt.cont, (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), once ctxt.ccont) - with exn -> - if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - ctxt.econt edi |> unfake + MakeAsyncWithCancelCheck (fun ctxt -> + let mutable underCurrentThreadStack = true + let mutable contToTailCall = None + let thread = Thread.CurrentThread + let latch = Latch() + let once cont x = + if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + if Thread.CurrentThread.Equals thread && underCurrentThreadStack then + contToTailCall <- Some(fun () -> cont x) + elif Trampoline.ThisThreadHasTrampoline then + let syncCtxt = SynchronizationContext.Current + ctxt.trampolineHolder.PostOrQueueWithTrampoline syncCtxt (fun () -> cont x) |> unfake + else + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont x ) |> unfake + try + callback (once ctxt.cont, (fun exn -> once ctxt.econt (ExceptionDispatchInfo.RestoreOrCapture exn)), once ctxt.ccont) + with exn -> + if not(latch.Enter()) then invalidOp(SR.GetString(SR.controlContinuationInvokedMultipleTimes)) + let edi = ExceptionDispatchInfo.RestoreOrCapture exn + ctxt.econt edi |> unfake - underCurrentThreadStack <- false + underCurrentThreadStack <- false - match contToTailCall with - | Some k -> k() - | _ -> fake()) + match contToTailCall with + | Some k -> k() + | _ -> fake()) static member DefaultCancellationToken = defaultCancellationTokenSource.Token static member CancelDefaultToken() = - let cts = defaultCancellationTokenSource - // set new CancellationTokenSource before calling Cancel - otherwise if Cancel throws token will stay unchanged defaultCancellationTokenSource <- new CancellationTokenSource() - cts.Cancel() - // we do not dispose the old default CTS - let GC collect it static member Catch (computation: Async<'T>) = @@ -1164,46 +1250,46 @@ namespace Microsoft.FSharp.Control AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions static member StartChildAsTask (computation, ?taskCreationOptions) = - async { let! cancellationToken = cancellationTokenAsync - return AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions } + async { + let! cancellationToken = cancellationTokenAsync + return AsyncPrimitives.StartAsTask cancellationToken computation taskCreationOptions + } - static member Parallel (computations: seq>) = Async.Parallel(computations, ?maxDegreeOfParallelism=None) + static member Parallel (computations: seq>) = + Async.Parallel(computations, ?maxDegreeOfParallelism=None) static member Parallel (computations: seq>, ?maxDegreeOfParallelism: int) = match maxDegreeOfParallelism with | Some x when x < 1 -> raise(System.ArgumentException(String.Format(SR.GetString(SR.maxDegreeOfParallelismNotPositive), x), "maxDegreeOfParallelism")) | _ -> () - MakeAsync (fun ctxt -> - let tasks, result = + MakeAsyncWithCancelCheck (fun ctxt -> + // manually protect eval of seq + let result = try - Seq.toArray computations, None // manually protect eval of seq + Choice1Of2 (Seq.toArray computations) with exn -> - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - null, Some (ctxt.econt edi) + Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) match result with - | Some r -> r - | None -> - if tasks.Length = 0 then - // must not be in a 'protect' if we call cont explicitly; if cont throws, it should unwind the stack, preserving Dev10 behavior - ctxt.cont [| |] - else - ProtectedCode ctxt (fun ctxt -> - let ctxtWithSync = DelimitSyncContext ctxt // manually resync - let mutable count = tasks.Length + | Choice2Of2 edi -> ctxt.econt edi + | Choice1Of2 [| |] -> ctxt.cont [| |] + | Choice1Of2 computations -> + ctxt.ProtectCode (fun () -> + let ctxt = DelimitSyncContext ctxt // manually resync + let mutable count = computations.Length let mutable firstExn = None - let results = Array.zeroCreate tasks.Length + let results = Array.zeroCreate computations.Length // Attempt to cancel the individual operations if an exception happens on any of the other threads - let innerCTS = new LinkedSubSource(ctxtWithSync.token) + let innerCTS = new LinkedSubSource(ctxt.token) let finishTask remaining = if (remaining = 0) then innerCTS.Dispose() match firstExn with - | None -> ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.cont results) - | Some (Choice1Of2 exn) -> ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.econt exn) - | Some (Choice2Of2 cexn) -> ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.ccont cexn) + | None -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont results) + | Some (Choice1Of2 exn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) + | Some (Choice2Of2 cexn) -> ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) else fake() @@ -1233,14 +1319,14 @@ namespace Microsoft.FSharp.Control let maxDegreeOfParallelism = match maxDegreeOfParallelism with | None -> None - | Some x when x >= tasks.Length -> None + | Some x when x >= computations.Length -> None | Some _ as x -> x // Simple case (no maxDegreeOfParallelism) just queue all the work, if we have maxDegreeOfParallelism set we start that many workers // which will make progress on the actual computations match maxDegreeOfParallelism with | None -> - tasks |> Array.iteri (fun i p -> + computations |> Array.iteri (fun i p -> QueueAsync innerCTS.Token // on success, record the result @@ -1254,9 +1340,9 @@ namespace Microsoft.FSharp.Control | Some maxDegreeOfParallelism -> let mutable i = -1 let rec worker (trampolineHolder : TrampolineHolder) = - if i < tasks.Length then + if i < computations.Length then let j = Interlocked.Increment &i - if j < tasks.Length then + if j < computations.Length then if innerCTS.Token.IsCancellationRequested then let cexn = OperationCanceledException (innerCTS.Token) recordFailure (Choice2Of2 cexn) |> unfake @@ -1269,7 +1355,7 @@ namespace Microsoft.FSharp.Control (fun res -> recordSuccess j res |> unfake; worker trampolineHolder) (fun edi -> recordFailure (Choice1Of2 edi) |> unfake; worker trampolineHolder) (fun cexn -> recordFailure (Choice2Of2 cexn) |> unfake; worker trampolineHolder) - tasks.[j].Invoke taskCtxt |> unfake + computations.[j].Invoke taskCtxt |> unfake fake() for x = 1 to maxDegreeOfParallelism do let trampolineHolder = TrampolineHolder() @@ -1279,10 +1365,11 @@ namespace Microsoft.FSharp.Control fake())) - static member Sequential (computations: seq>) = Async.Parallel(computations, maxDegreeOfParallelism=1) + static member Sequential (computations: seq>) = + Async.Parallel(computations, maxDegreeOfParallelism=1) static member Choice(computations: Async<'T option> seq) : Async<'T option> = - MakeAsync (fun ctxt -> + MakeAsyncWithCancelCheck (fun ctxt -> let result = try Seq.toArray computations |> Choice1Of2 with exn -> ExceptionDispatchInfo.RestoreOrCapture exn |> Choice2Of2 @@ -1291,25 +1378,25 @@ namespace Microsoft.FSharp.Control | Choice2Of2 edi -> ctxt.econt edi | Choice1Of2 [||] -> ctxt.cont None | Choice1Of2 computations -> - ProtectedCode ctxt (fun ctxt -> - let ctxtWithSync = DelimitSyncContext ctxt + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> let mutable count = computations.Length let mutable noneCount = 0 let mutable someOrExnCount = 0 - let innerCts = new LinkedSubSource(ctxtWithSync.token) + let innerCts = new LinkedSubSource(ctxt.token) let scont (result: 'T option) = let result = match result with | Some _ -> if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.cont result) + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont result) else fake() | None -> if Interlocked.Increment &noneCount = computations.Length then - innerCts.Cancel(); ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.cont None) + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont None) else fake() @@ -1321,7 +1408,7 @@ namespace Microsoft.FSharp.Control let econt (exn: ExceptionDispatchInfo) = let result = if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.econt exn) + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.econt exn) else fake() @@ -1330,10 +1417,10 @@ namespace Microsoft.FSharp.Control result - let ccont (exn: OperationCanceledException) = + let ccont (cexn: OperationCanceledException) = let result = if Interlocked.Increment &someOrExnCount = 1 then - innerCts.Cancel(); ctxtWithSync.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxtWithSync.ccont exn) + innerCts.Cancel(); ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont cexn) else fake() @@ -1342,8 +1429,8 @@ namespace Microsoft.FSharp.Control result - for c in computations do - QueueAsync innerCts.Token scont econt ccont c |> unfake + for computation in computations do + QueueAsync innerCts.Token scont econt ccont computation |> unfake fake())) @@ -1372,44 +1459,37 @@ namespace Microsoft.FSharp.Control AsyncPrimitives.StartWithContinuations cancellationToken computation id (fun edi -> edi.ThrowAny()) ignore static member Sleep (millisecondsDueTime: int64) : Async = - CreateDelimitedUserCodeAsync (fun ctxt -> - let mutable timer = None: Timer option - let cont = ctxt.cont - let ccont = ctxt.ccont - let latch = Latch() - let registration = - ctxt.token.Register( - (fun () -> - if latch.Enter() then - match timer with - | None -> () - | Some t -> t.Dispose() - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ccont(OperationCanceledException(ctxt.token))) |> unfake) - ) + MakeAsyncWithCancelCheck (fun ctxt -> + let ctxt = DelimitSyncContext ctxt let mutable edi = null + let latch = Latch() + let mutable timer: Timer option = None + let mutable registration: CancellationTokenRegistration option = None + registration <- + ctxt.token.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeRegistration ®istration + DisposeTimer &timer + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake) + ) |> Some try - timer <- new Timer((fun _ -> + timer <- new Timer(TimerCallback(fun _ -> if latch.Enter() then - // NOTE: If the CTS for the token would have been disposed, disposal of the registration would throw - // However, our contract is that until async computation ceases execution (and invokes ccont) - // the CTS will not be disposed. Execution of savedCCont is guarded by latch, so we are safe unless - // user violates the contract. - registration.Dispose() - // Try to Dispose of the Timer. - // Note: there is a race here: the Timer time very occasionally - // calls the callback _before_ the timer object has been recorded anywhere. This makes it difficult to dispose the - // timer in this situation. In this case we just let the timer be collected by finalization. - match timer with - | None -> () - | Some t -> t.Dispose() + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + DisposeTimer &timer // Now we're done, so call the continuation - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> cont()) |> unfake), + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont()) |> unfake), null, dueTime=millisecondsDueTime, period = -1L) |> Some with exn -> if latch.Enter() then - // post exception to econt only if we successfully enter the latch (no other continuations were called) + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + // Prepare to call exception continuation edi <- ExceptionDispatchInfo.RestoreOrCapture exn + // Call exception continuation if necessary match edi with | null -> fake() @@ -1427,74 +1507,72 @@ namespace Microsoft.FSharp.Control /// Wait for a wait handle. Both timeout and cancellation are supported static member AwaitWaitHandle(waitHandle: WaitHandle, ?millisecondsTimeout:int) = - let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite - if millisecondsTimeout = 0 then - async.Delay(fun () -> + MakeAsyncWithCancelCheck (fun ctxt -> + let millisecondsTimeout = defaultArg millisecondsTimeout Threading.Timeout.Infinite + if millisecondsTimeout = 0 then let ok = waitHandle.WaitOne(0, exitContext=false) - async.Return ok) - else - CreateDelimitedUserCodeAsync(fun ctxt -> - let aux = ctxt.aux - let rwh = ref (None: RegisteredWaitHandle option) + ctxt.cont ok + else + let ctxt = DelimitSyncContext ctxt + let mutable edi = null let latch = Latch() - let rec cancelHandler = - Action(fun () -> + let mutable rwh: RegisteredWaitHandle option = None + let mutable registration: CancellationTokenRegistration option = None + registration <- + ctxt.token.Register(Action(fun () -> if latch.Enter() then - // if we got here - then we need to unregister RegisteredWaitHandle + trigger cancellation - // entrance to TP callback is protected by latch - so savedCont will never be called - lock rwh (fun () -> - match !rwh with - | None -> () - | Some rwh -> rwh.Unregister null |> ignore) - Async.Start (async { do (ctxt.ccont (OperationCanceledException(aux.token)) |> unfake) })) + // Make sure we're not cancelled again + DisposeRegistration ®istration - and registration: CancellationTokenRegistration = aux.token.Register(cancelHandler) + UnregisterWaitHandle &rwh + + // Call the cancellation continuation + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.ccont(OperationCanceledException(ctxt.token))) |> unfake)) + |> Some - let savedCont = ctxt.cont try - lock rwh (fun () -> - rwh := Some(ThreadPool.RegisterWaitForSingleObject - (waitObject=waitHandle, - callBack=WaitOrTimerCallback(fun _ timeOut -> - if latch.Enter() then - lock rwh (fun () -> rwh.Value.Value.Unregister null |> ignore) - rwh := None - registration.Dispose() - ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> savedCont (not timeOut)) |> unfake), - state=null, - millisecondsTimeOutInterval=millisecondsTimeout, - executeOnlyOnce=true)) - fake()) - with _ -> + rwh <- ThreadPool.RegisterWaitForSingleObject(waitObject=waitHandle, + callBack=WaitOrTimerCallback(fun _ timeOut -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + UnregisterWaitHandle &rwh + // Call the success continuation + ctxt.trampolineHolder.ExecuteWithTrampoline (fun () -> ctxt.cont (not timeOut)) |> unfake), + state=null, + millisecondsTimeOutInterval=millisecondsTimeout, + executeOnlyOnce=true) + |> Some + with exn -> if latch.Enter() then - registration.Dispose() - reraise() // reraise exception only if we successfully enter the latch (no other continuations were called) - else - fake() - ) - - static member AwaitIAsyncResult(iar: IAsyncResult, ?millisecondsTimeout): Async = - async { if iar.CompletedSynchronously then - return true - else - return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout=millisecondsTimeout) } + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + // Prepare to call exception continuation + edi <- ExceptionDispatchInfo.RestoreOrCapture exn + // Call exception continuation if necessary + match edi with + | null -> + fake() + | _ -> + // Call the exception continuation + ctxt.econt edi) - /// Bind the result of a result cell, calling the appropriate continuation. - static member BindResult (result: AsyncResult<'T>) : Async<'T> = - MakeAsync (fun ctxt -> - (match result with - | Ok v -> ctxt.cont v - | Error exn -> ctxt.econt exn - | Canceled exn -> ctxt.ccont exn) ) + static member AwaitIAsyncResult(iar: IAsyncResult, ?millisecondsTimeout) = + async { + if iar.CompletedSynchronously then + return true + else + return! Async.AwaitWaitHandle(iar.AsyncWaitHandle, ?millisecondsTimeout=millisecondsTimeout) + } /// Await and use the result of a result cell. The resulting async doesn't support cancellation /// or timeout directly, rather the underlying computation must fill the result if cancellation /// or timeout occurs. - static member AwaitAndBindResult_NoDirectCancelOrTimeout(resultCell: ResultCell>) : Async<'T> = + static member AwaitAndBindResult_NoDirectCancelOrTimeout(resultCell: ResultCell>) = async { let! result = resultCell.AwaitResult_NoDirectCancelOrTimeout - return! Async.BindResult result + return! CreateAsyncResultAsync result } /// Await the result of a result cell belonging to a child computation. The resulting async supports timeout and if @@ -1512,81 +1590,81 @@ namespace Microsoft.FSharp.Control else return raise (System.TimeoutException()) } | _ -> - async { try - if resultCell.ResultAvailable then - let res = resultCell.GrabResult() - return res.Commit() - else - let! ok = Async.AwaitWaitHandle (resultCell.GetWaitHandle(), ?millisecondsTimeout=millisecondsTimeout) - if ok then + async { + try + if resultCell.ResultAvailable then + let res = resultCell.GrabResult() + return res.Commit() + else + let! ok = Async.AwaitWaitHandle (resultCell.GetWaitHandle(), ?millisecondsTimeout=millisecondsTimeout) + if ok then let res = resultCell.GrabResult() return res.Commit() - else // timed out + else // timed out // issue cancellation signal innerCTS.Cancel() // wait for computation to quiesce let! _ = Async.AwaitWaitHandle (resultCell.GetWaitHandle()) return raise (System.TimeoutException()) - finally - resultCell.Close() } + finally + resultCell.Close() + } static member FromBeginEnd(beginAction, endAction, ?cancelAction): Async<'T> = - async { let! cancellationToken = cancellationTokenAsync - let resultCell = new ResultCell<_>() + async { + let! ct = cancellationTokenAsync + let resultCell = new ResultCell<_>() - let once = Once() + let latch = Latch() - let registration: CancellationTokenRegistration = + let mutable registration: CancellationTokenRegistration option = None + registration <- + ct.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeRegistration ®istration - let onCancel () = - // Call the cancellation routine + // Call the cancellation function. Ignore any exceptions from the + // cancellation function. match cancelAction with - | None -> - // Register the result. This may race with a successful result, but - // ResultCell allows a race and throws away whichever comes last. - once.Do(fun () -> - let canceledResult = Canceled (OperationCanceledException cancellationToken) - resultCell.RegisterResult(canceledResult, reuseThread=true) |> unfake - ) + | None -> () | Some cancel -> - // If we get an exception from a cooperative cancellation function - // we assume the operation has already completed. try cancel() with _ -> () - cancellationToken.Register(Action(onCancel)) - - let callback = - System.AsyncCallback(fun iar -> - if not iar.CompletedSynchronously then - // The callback has been activated, so ensure cancellation is not possible - // beyond this point. - match cancelAction with - | Some _ -> - registration.Dispose() - | None -> - once.Do(fun () -> registration.Dispose()) - - // Run the endAction and collect its result. - let res = - try - Ok(endAction iar) - with exn -> - let edi = ExceptionDispatchInfo.RestoreOrCapture exn - Error edi - - // Register the result. This may race with a cancellation result, but - // ResultCell allows a race and throws away whichever comes last. - resultCell.RegisterResult(res, reuseThread=true) |> unfake) - - let (iar:IAsyncResult) = beginAction (callback, (null:obj)) - if iar.CompletedSynchronously then - registration.Dispose() - return endAction iar - else - // Note: ok to use "NoDirectCancel" here because cancellation has been registered above - // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method - return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } + // Register the cancellation result. + let canceledResult = Canceled (OperationCanceledException ct) + resultCell.RegisterResult(canceledResult, reuseThread=true) |> unfake)) + |> Some + + let callback = + AsyncCallback(fun iar -> + if not iar.CompletedSynchronously then + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + + // Run the endAction and collect its result. + let res = + try + Ok(endAction iar) + with exn -> + let edi = ExceptionDispatchInfo.RestoreOrCapture exn + Error edi + + // Register the result. + resultCell.RegisterResult(res, reuseThread=true) |> unfake) + + let (iar:IAsyncResult) = beginAction (callback, (null:obj)) + if iar.CompletedSynchronously then + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration + return endAction iar + else + // Note: ok to use "NoDirectCancel" here because cancellation has been registered above + // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method + return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell + } static member FromBeginEnd(arg, beginAction, endAction, ?cancelAction): Async<'T> = @@ -1609,44 +1687,52 @@ namespace Microsoft.FSharp.Control beginAction, AsBeginEndHelpers.endAction<'T>, AsBeginEndHelpers.cancelAction<'T> static member AwaitEvent(event:IEvent<'Delegate, 'T>, ?cancelAction) : Async<'T> = - async { let! cancellationToken = cancellationTokenAsync - let resultCell = new ResultCell<_>() - // Set up the handlers to listen to events and cancellation - let once = Once() - let rec registration: CancellationTokenRegistration= - let onCancel () = - // We've been cancelled. Call the given cancellation routine + async { + let! ct = cancellationTokenAsync + let resultCell = new ResultCell<_>() + // Set up the handlers to listen to events and cancellation + let latch = Latch() + let mutable registration: CancellationTokenRegistration option = None + let mutable del: 'Delegate option = None + registration <- + ct.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeRegistration ®istration + + // Stop listening to events + RemoveHandler event &del + + // Call the given cancellation routine if we've been given one + // Exceptions from a cooperative cancellation are ignored. match cancelAction with - | None -> - // We've been cancelled without a cancel action. Stop listening to events - event.RemoveHandler del - // Register the result. This may race with a successful result, but - // ResultCell allows a race and throws away whichever comes last. - once.Do(fun () -> resultCell.RegisterResult(Canceled (OperationCanceledException cancellationToken), reuseThread=true) |> unfake) + | None -> () | Some cancel -> - // If we get an exception from a cooperative cancellation function - // we assume the operation has already completed. try cancel() with _ -> () - cancellationToken.Register(Action(onCancel)) + + // Register the cancellation result. + resultCell.RegisterResult(Canceled (OperationCanceledException ct), reuseThread=true) |> unfake + )) |> Some + + let del = + FuncDelegate<'T>.Create<'Delegate>(fun eventArgs -> + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration - and del = - FuncDelegate<'T>.Create<'Delegate>(fun eventArgs -> // Stop listening to events - event.RemoveHandler del - // The callback has been activated, so ensure cancellation is not possible beyond this point - once.Do(fun () -> registration.Dispose()) - let res = Ok eventArgs - // Register the result. This may race with a cancellation result, but - // ResultCell allows a race and throws away whichever comes last. - resultCell.RegisterResult(res, reuseThread=true) |> unfake) - - // Start listening to events - event.AddHandler del - - // Return the async computation that allows us to await the result - // Note: ok to use "NoDirectCancel" here because cancellation has been registered above - // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method - return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } + RemoveHandler event &del + + // Register the successful result. + resultCell.RegisterResult(Ok eventArgs, reuseThread=true) |> unfake) + + // Start listening to events + event.AddHandler del + + // Return the async computation that allows us to await the result + // Note: ok to use "NoDirectCancel" here because cancellation has been registered above + // Note: ok to use "NoDirectTimeout" here because no timeout parameter to this method + return! Async.AwaitAndBindResult_NoDirectCancelOrTimeout resultCell } static member Ignore (computation: Async<'T>) = CreateIgnoreAsync computation @@ -1657,65 +1743,86 @@ namespace Microsoft.FSharp.Control static member StartChild (computation:Async<'T>, ?millisecondsTimeout) = async { let resultCell = new ResultCell<_>() - let! cancellationToken = cancellationTokenAsync + let! ct = cancellationTokenAsync let innerCTS = new CancellationTokenSource() // innerCTS does not require disposal let mutable ctsRef = innerCTS - let reg = cancellationToken.Register( - (fun () -> - match ctsRef with - | null -> () - | otherwise -> otherwise.Cancel())) + let registration = + ct.Register(Action(fun () -> + match ctsRef with + | null -> () + | otherwise -> otherwise.Cancel())) + do QueueAsync innerCTS.Token // since innerCTS is not ever Disposed, can call reg.Dispose() without a safety Latch - (fun res -> ctsRef <- null; reg.Dispose(); resultCell.RegisterResult (Ok res, reuseThread=true)) - (fun edi -> ctsRef <- null; reg.Dispose(); resultCell.RegisterResult (Error edi, reuseThread=true)) - (fun err -> ctsRef <- null; reg.Dispose(); resultCell.RegisterResult (Canceled err, reuseThread=true)) + (fun res -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Ok res, reuseThread=true)) + (fun edi -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Error edi, reuseThread=true)) + (fun err -> ctsRef <- null; registration.Dispose(); resultCell.RegisterResult (Canceled err, reuseThread=true)) computation |> unfake return Async.AwaitAndBindChildResult(innerCTS, resultCell, millisecondsTimeout) } static member SwitchToContext syncContext = - async { match syncContext with - | null -> - // no synchronization context, just switch to the thread pool - do! Async.SwitchToThreadPool() - | syncCtxt -> - // post the continuation to the synchronization context - return! CreateSwitchToAsync syncCtxt } + async { + match syncContext with + | null -> + // no synchronization context, just switch to the thread pool + do! Async.SwitchToThreadPool() + | syncCtxt -> + // post the continuation to the synchronization context + return! CreateSwitchToAsync syncCtxt + } static member OnCancel interruption = - async { let! cancellationToken = cancellationTokenAsync - // latch protects CancellationTokenRegistration.Dispose from being called twice - let latch = Latch() - let rec handler () = - try - if latch.Enter() then registration.Dispose() - interruption () - with _ -> () - and registration: CancellationTokenRegistration = cancellationToken.Register(Action(handler)) - return { new System.IDisposable with - member this.Dispose() = - // dispose CancellationTokenRegistration only if cancellation was not requested. - // otherwise - do nothing, disposal will be performed by the handler itself - if not cancellationToken.IsCancellationRequested then - if latch.Enter() then registration.Dispose() } } + async { + let! ct = cancellationTokenAsync + // latch protects cancellation and disposal contention + let latch = Latch() + let mutable registration: CancellationTokenRegistration option = None + registration <- + ct.Register(Action(fun () -> + if latch.Enter() then + // Make sure we're not cancelled again + DisposeRegistration ®istration + try + interruption () + with _ -> ())) + |> Some + let disposer = + { new System.IDisposable with + member _.Dispose() = + // dispose CancellationTokenRegistration only if cancellation was not requested. + // otherwise - do nothing, disposal will be performed by the handler itself + if not ct.IsCancellationRequested then + if latch.Enter() then + // Ensure cancellation is not possible beyond this point + DisposeRegistration ®istration } + return disposer + } static member TryCancelled (computation: Async<'T>, compensation) = CreateWhenCancelledAsync compensation computation static member AwaitTask (task:Task<'T>) : Async<'T> = - if task.IsCompleted then - MakeAsync (fun ctxt -> OnTaskCompleted task ctxt) - else - CreateDelimitedUserCodeAsync (fun ctxt -> AttachContinuationToTask task ctxt) + MakeAsyncWithCancelCheck (fun ctxt -> + if task.IsCompleted then + // Run synchronously without installing new trampoline + OnTaskCompleted task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> AttachContinuationToTask task ctxt)) static member AwaitTask (task:Task) : Async = - if task.IsCompleted then - MakeAsync (fun ctxt -> OnUnitTaskCompleted task ctxt) - else - CreateDelimitedUserCodeAsync (fun ctxt -> AttachContinuationToUnitTask task ctxt) + MakeAsyncWithCancelCheck (fun ctxt -> + if task.IsCompleted then + // Continue synchronously without installing new trampoline + OnUnitTaskCompleted task ctxt + else + // Continue asynchronously, via syncContext if necessary, installing new trampoline + let ctxt = DelimitSyncContext ctxt + ctxt.ProtectCode (fun () -> AttachContinuationToUnitTask task ctxt)) module CommonExtensions = @@ -1729,14 +1836,16 @@ namespace Microsoft.FSharp.Control [] // give the extension member a 'nice', unmangled compiled name, unique within this module member stream.AsyncRead count = - async { let buffer = Array.zeroCreate count - let mutable i = 0 - while i < count do - let! n = stream.AsyncRead(buffer, i, count - i) - i <- i + n - if n = 0 then - raise(System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) - return buffer } + async { + let buffer = Array.zeroCreate count + let mutable i = 0 + while i < count do + let! n = stream.AsyncRead(buffer, i, count - i) + i <- i + n + if n = 0 then + raise(System.IO.EndOfStreamException(SR.GetString(SR.failedReadEnoughBytes))) + return buffer + } [] // give the extension member a 'nice', unmangled compiled name, unique within this module member stream.AsyncWrite(buffer:byte[], ?offset:int, ?count:int) = @@ -1773,7 +1882,7 @@ namespace Microsoft.FSharp.Control | :? System.Net.WebException as webExn when webExn.Status = System.Net.WebExceptionStatus.RequestCanceled && canceled -> - Some (Async.BindResult(AsyncResult.Canceled (OperationCanceledException webExn.Message))) + Some (CreateAsyncResultAsync(AsyncResult.Canceled (OperationCanceledException webExn.Message))) | _ -> None) 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 303df51ecb8..4c6be0c832a 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 @@ -193,7 +193,7 @@ type AsyncModule() = member this.AwaitIAsyncResult() = let beginOp, endOp, cancelOp = Async.AsBeginEnd(fun() -> getTicksTask) - + (* // Begin the async operation and wait let operationIAR = beginOp ((), new AsyncCallback(fun iar -> ()), null) match Async.AwaitIAsyncResult(operationIAR) |> Async.RunSynchronously with @@ -208,7 +208,7 @@ type AsyncModule() = match result with | true -> () | false -> Assert.Fail("Timed out. Expected to succeed.") - + *) // Now with a timeout let operationIAR = beginOp ((), new AsyncCallback(fun iar -> ()), null) let result = Async.AwaitIAsyncResult(operationIAR, 1) |> Async.RunSynchronously From 41be0c19e84fec49e63f3a38e50c77fcca362645 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 23:37:29 +0100 Subject: [PATCH 5/9] add benchmarks --- FSharp.sln | 32 ++++++++++++++++++++++++ tests/benchmarks/MicroPerf/Benchmarks.fs | 21 +++++++++++++++- 2 files changed, 52 insertions(+), 1 deletion(-) diff --git a/FSharp.sln b/FSharp.sln index 271327a2281..bcbb76848ae 100644 --- a/FSharp.sln +++ b/FSharp.sln @@ -66,6 +66,12 @@ Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "CSharp_Analysis", "tests\se EndProject Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "TestTP", "tests\service\data\TestTP\TestTP.fsproj", "{7BFA159A-BF9D-4489-BF46-1B83ACCEEE0F}" EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Benchmarks", "Benchmarks", "{E02ADBCA-D6C0-4898-A8AA-86DE6EBE2DC2}" +EndProject +Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "MicroPerfCSharp", "tests\benchmarks\MicroPerf\CS\MicroPerfCSharp.csproj", "{2904313F-7782-4522-894C-DC946DFFE22D}" +EndProject +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "MicroPerf", "tests\benchmarks\MicroPerf\MicroPerf.fsproj", "{C888A81D-2372-4B4A-8BA1-525AEE3918D6}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -328,6 +334,30 @@ Global {7BFA159A-BF9D-4489-BF46-1B83ACCEEE0F}.Release|Any CPU.Build.0 = Release|Any CPU {7BFA159A-BF9D-4489-BF46-1B83ACCEEE0F}.Release|x86.ActiveCfg = Release|Any CPU {7BFA159A-BF9D-4489-BF46-1B83ACCEEE0F}.Release|x86.Build.0 = Release|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Debug|Any CPU.Build.0 = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Debug|x86.ActiveCfg = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Debug|x86.Build.0 = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Proto|Any CPU.ActiveCfg = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Proto|Any CPU.Build.0 = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Proto|x86.ActiveCfg = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Proto|x86.Build.0 = Debug|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Release|Any CPU.ActiveCfg = Release|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Release|Any CPU.Build.0 = Release|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Release|x86.ActiveCfg = Release|Any CPU + {2904313F-7782-4522-894C-DC946DFFE22D}.Release|x86.Build.0 = Release|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Debug|Any CPU.Build.0 = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Debug|x86.ActiveCfg = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Debug|x86.Build.0 = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Proto|Any CPU.ActiveCfg = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Proto|Any CPU.Build.0 = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Proto|x86.ActiveCfg = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Proto|x86.Build.0 = Debug|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Release|Any CPU.ActiveCfg = Release|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Release|Any CPU.Build.0 = Release|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Release|x86.ActiveCfg = Release|Any CPU + {C888A81D-2372-4B4A-8BA1-525AEE3918D6}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -357,6 +387,8 @@ Global {452EED3C-AA87-471F-B9AC-0F4479C5820C} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} {F8743670-C8D4-41B3-86BE-BBB1226C352F} = {452EED3C-AA87-471F-B9AC-0F4479C5820C} {7BFA159A-BF9D-4489-BF46-1B83ACCEEE0F} = {452EED3C-AA87-471F-B9AC-0F4479C5820C} + {2904313F-7782-4522-894C-DC946DFFE22D} = {E02ADBCA-D6C0-4898-A8AA-86DE6EBE2DC2} + {C888A81D-2372-4B4A-8BA1-525AEE3918D6} = {E02ADBCA-D6C0-4898-A8AA-86DE6EBE2DC2} EndGlobalSection GlobalSection(ExtensibilityGlobals) = postSolution SolutionGuid = {BD5177C7-1380-40E7-94D2-7768E1A8B1B8} diff --git a/tests/benchmarks/MicroPerf/Benchmarks.fs b/tests/benchmarks/MicroPerf/Benchmarks.fs index cb264e065e3..910ca10736b 100644 --- a/tests/benchmarks/MicroPerf/Benchmarks.fs +++ b/tests/benchmarks/MicroPerf/Benchmarks.fs @@ -40,10 +40,29 @@ type Benchmarks() = member _.FSharp(x: int) = Code.condition_2(x) +[] +[] +[] +[] +type AsyncWhileMemoryBench() = + + [] + member val Length = 0 with get, set + + [] + member x.Run() = + async { + let mutable i = 0 + while i < x.Length do + i <- i + 1 + return i + } |> Async.StartAsTask + module Main = [] let main argv = printfn "Running benchmarks..." - let results = BenchmarkRunner.Run() + //let results = BenchmarkRunner.Run() + let results = BenchmarkRunner.Run() 0 From 80ed8b6b77240953ae0f9c5d2f8a27025f353b7c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 8 Jul 2021 23:56:57 +0100 Subject: [PATCH 6/9] revert addition of extra hijack check on Bind for performance reasons --- src/fsharp/FSharp.Core/async.fs | 78 ++++++++++++------- .../MicroPerf/CS/MicroPerfCSharp.csproj | 6 ++ 2 files changed, 58 insertions(+), 26 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index e51594fce65..aa480f03e98 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -40,6 +40,9 @@ namespace Microsoft.FSharp.Control let associationTable = ConditionalWeakTable() + [] + let bindLimitBeforeHijack = 300 + type ExceptionDispatchInfo with member edi.GetAssociatedSourceException() = @@ -76,9 +79,6 @@ namespace Microsoft.FSharp.Control [] type Trampoline() = - [] - static let bindLimitBeforeHijack = 300 - [] static val mutable private thisThreadHasTrampoline: bool @@ -414,6 +414,24 @@ namespace Microsoft.FSharp.Control else fake() + /// Like `CallThenInvoke` but does not do a hijack check for historical reasons (exact code compat) + [] + let CallThenInvokeNoHijackCheck (ctxt: AsyncActivation<_>) result1 userCode = + let mutable res = Unchecked.defaultof<_> + let mutable ok = false + + try + res <- userCode result1 + ok <- true + finally + if not ok then + ctxt.OnExceptionRaised() + + if ok then + res.Invoke ctxt + else + fake() + /// Apply 'filterFunction' to 'arg'. If the result is 'Some' invoke the resulting computation. If the result is 'None' /// then send 'result1' to the exception continuation. /// @@ -457,7 +475,7 @@ namespace Microsoft.FSharp.Control /// Note: direct calls to this function end up in user assemblies via inlining /// - Initial cancellation check /// - Initial hijack check (see Invoke) - /// - Hijack check after applying 'part2' to argument (see CallThenInvoke) + /// - No hijack check after applying 'part2' to argument (see CallThenInvoke) /// - No cancellation check after applying 'part2' to argument (see CallThenInvoke) /// - Apply 'part2' to argument with exception protection (see CallThenInvoke) [] @@ -468,7 +486,7 @@ namespace Microsoft.FSharp.Control // Note, no cancellation check is done before calling 'part2'. This is // because part1 may bind a resource, while part2 is a try/finally, and, if // the resource creation completes, we want to enter part2 before cancellation takes effect. - Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvoke ctxt result1 part2)) + Invoke part1 (ctxt.WithContinuation(fun result1 -> CallThenInvokeNoHijackCheck ctxt result1 part2)) /// Re-route all continuations to execute the finally function. /// - Cancellation check after 'entering' the try/finally and before running the body @@ -476,7 +494,7 @@ namespace Microsoft.FSharp.Control /// - Run 'finallyFunction' with exception protection (see CallThenContinue) /// - Hijack check before any of the continuations (see CallThenContinue) [] - let TryFinally (ctxt: AsyncActivation<'T>) computation finallyFunction = + let TryFinally (ctxt: AsyncActivation<'T>) (computation: Async<'T>) finallyFunction = // Note, we don't test for cancellation before entering a try/finally. This prevents // a resource being created without being disposed. @@ -499,17 +517,17 @@ namespace Microsoft.FSharp.Control if ctxt.IsCancellationRequested then ctxt.OnCancellation () else - Invoke computation ctxt + computation.Invoke ctxt /// Re-route the exception continuation to call to catchFunction. If catchFunction returns None then call the exception continuation. /// If it returns Some, invoke the resulting async. /// - Cancellation check before entering the try - /// - Hijack check after 'entering' the try/with + /// - No hijack check after 'entering' the try/with /// - Cancellation check before applying the 'catchFunction' /// - Apply `catchFunction' to argument with exception protection (see CallFilterThenInvoke) - /// - Hijack check before invoking the resulting computation or exception continuation + /// - Hijack check before invoking the resulting computation or exception continuation (see CallFilterThenInvoke) [] - let TryWith (ctxt: AsyncActivation<'T>) computation catchFunction = + let TryWith (ctxt: AsyncActivation<'T>) (computation: Async<'T>) catchFunction = if ctxt.IsCancellationRequested then ctxt.OnCancellation () else @@ -520,7 +538,7 @@ namespace Microsoft.FSharp.Control else CallFilterThenInvoke ctxt catchFunction edi) - Invoke computation ctxt + computation.Invoke ctxt /// Make an async for an AsyncResult // - No cancellation check @@ -542,7 +560,7 @@ namespace Microsoft.FSharp.Control /// Runs the first process, takes its result, applies f and then runs the new process produced. /// - Initial cancellation check (see Bind) /// - Initial hijack check (see Bind) - /// - Hijack check after applying 'part2' to argument (see Bind) + /// - No hijack check after applying 'part2' to argument (see Bind) /// - No cancellation check after applying 'part2' to argument (see Bind) /// - Apply 'part2' to argument with exception protection (see Bind) let inline CreateBindAsync part1 part2 = @@ -570,7 +588,7 @@ namespace Microsoft.FSharp.Control /// Implements the sequencing construct of async computation expressions /// - Initial cancellation check (see CreateBindAsync) /// - Initial hijack check (see CreateBindAsync) - /// - Hijack check after applying 'part2' to argument (see CreateBindAsync) + /// - No hijack check after applying 'part2' to argument (see CreateBindAsync) /// - No cancellation check after applying 'part2' to argument (see CreateBindAsync) /// - Apply 'part2' to argument with exception protection (see CreateBindAsync) let inline CreateSequentialAsync part1 part2 = @@ -638,35 +656,43 @@ namespace Microsoft.FSharp.Control /// - Initial cancellation check (see CreateBindAsync) /// - Initial hijack check (see CreateBindAsync) /// - Cancellation check after (see unitAsync) - /// - Hijack check after (see unitAsync) + /// - No hijack check after (see unitAsync) let inline CreateIgnoreAsync computation = CreateBindAsync computation (fun _ -> unitAsync) /// Implement the while loop construct of async computation expressions - /// - Initial cancellation check before initial execution of guard - /// - Initial hijack check before initial execution of guard - /// - Cancellation check before each execution of the body (see CreateSequentialAsync) - /// - Hijack check before each execution of the body (see CreateSequentialAsync) - /// - Hijack check after each execution of the body and before guard (see CreateSequentialAsync) - /// - No cancellation check after each execution of body and before guard (see CreateSequentialAsync) + /// - No initial cancellation check before first execution of guard + /// - No initial hijack check before first execution of guard + /// - No cancellation check before each execution of guard (see CreateBindAsync) + /// - Hijack check before each execution of guard (see CreateBindAsync) + /// - Cancellation check before each execution of the body after guard (CreateBindAsync) + /// - No hijack check before each execution of the body after guard (see CreateBindAsync) /// - Cancellation check after guard fails (see unitAsync) /// - Hijack check after guard fails (see unitAsync) - /// - Apply 'guardFunc' with exception protection + /// - Apply 'guardFunc' with exception protection (see ProtectCode) + // + // Note: There are allocations during loop set up, but no allocations during iterations of the loop let CreateWhileAsync guardFunc computation = - let mutable whileAsync = Unchecked.defaultof<_> - whileAsync <- CreateDelayAsync (fun () -> if guardFunc() then CreateSequentialAsync computation whileAsync else unitAsync) - whileAsync + if guardFunc() then + let mutable whileAsync = Unchecked.defaultof<_> + whileAsync <- CreateBindAsync computation (fun () -> if guardFunc() then whileAsync else unitAsync) + whileAsync + else + unitAsync /// Implement the for loop construct of async commputation expressions /// - No initial cancellation check before GetEnumerator call. /// - No initial cancellation check before entering protection of implied try/finally /// - Cancellation check after 'entering' the implied try/finally and before loop - /// - Hijack check after 'entering' the implied try/finally and before loop - /// - Once not apply 'GetEnumerator' with exception protection. However for an 'async' + /// - Hijack check after 'entering' the implied try/finally and after MoveNext call + /// - Do not apply 'GetEnumerator' with exception protection. However for an 'async' /// in an 'async { ... }' the exception protection will be provided by the enclosing // Delay or Bind or similar construct. /// - Apply 'MoveNext' with exception protection /// - Apply 'Current' with exception protection + + // Note: No allocations during iterations of the loop apart from those from + // applying the loop body to the element let CreateForLoopAsync (source: seq<_>) computation = CreateUsingAsync (source.GetEnumerator()) (fun ie -> CreateWhileAsync diff --git a/tests/benchmarks/MicroPerf/CS/MicroPerfCSharp.csproj b/tests/benchmarks/MicroPerf/CS/MicroPerfCSharp.csproj index 32ae4d1b867..875fdf3236c 100644 --- a/tests/benchmarks/MicroPerf/CS/MicroPerfCSharp.csproj +++ b/tests/benchmarks/MicroPerf/CS/MicroPerfCSharp.csproj @@ -6,6 +6,12 @@ 8.0 + + + + + + From ba826915cd0ae5f5e5018aed2dd8a250ba1ef995 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 9 Jul 2021 00:01:18 +0100 Subject: [PATCH 7/9] include low allocation implementations that run slower with #if --- src/fsharp/FSharp.Core/async.fs | 59 +++++++++++++++++++++++++++++++-- 1 file changed, 56 insertions(+), 3 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index aa480f03e98..cfdb3a984b2 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -40,9 +40,6 @@ namespace Microsoft.FSharp.Control let associationTable = ConditionalWeakTable() - [] - let bindLimitBeforeHijack = 300 - type ExceptionDispatchInfo with member edi.GetAssociatedSourceException() = @@ -79,6 +76,9 @@ namespace Microsoft.FSharp.Control [] type Trampoline() = + [] + static let bindLimitBeforeHijack = 300 + [] static val mutable private thisThreadHasTrampoline: bool @@ -680,6 +680,35 @@ namespace Microsoft.FSharp.Control else unitAsync +#if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER + /// Implement the while loop construct of async computation expressions + /// - Initial cancellation check before each execution of guard + /// - No initial hijack check before each execution of guard + /// - No cancellation check before each execution of the body after guard + /// - Hijack check before each execution of the body after guard (see Invoke) + /// - Cancellation check after guard fails (see OnSuccess) + /// - Hijack check after guard fails (see OnSuccess) + /// - Apply 'guardFunc' with exception protection (see ProtectCode) + // + // Note: There are allocations during loop set up, but no allocations during iterations of the loop + // One allocation for While async + // One allocation for While async context function + MakeAsync (fun ctxtGuard -> + // One allocation for ctxtLoop reference cell + let mutable ctxtLoop = Unchecked.defaultof<_> + // One allocation for While recursive closure + let rec WhileLoop () = + if ctxtGuard.IsCancellationRequested then + ctxtGuard.OnCancellation () + elif ctxtGuard.ProtectCode guardFunc then + Invoke computation ctxtLoop + else + ctxtGuard.OnSuccess () + // One allocation for While body activation context + ctxtLoop <- ctxtGuard.WithContinuation(WhileLoop) + WhileLoop ()) +#endif + /// Implement the for loop construct of async commputation expressions /// - No initial cancellation check before GetEnumerator call. /// - No initial cancellation check before entering protection of implied try/finally @@ -699,6 +728,30 @@ namespace Microsoft.FSharp.Control (fun () -> ie.MoveNext()) (CreateDelayAsync (fun () -> computation ie.Current))) +#if REDUCED_ALLOCATIONS_BUT_RUNS_SLOWER + CreateUsingAsync (source.GetEnumerator()) (fun ie -> + // One allocation for While async + // One allocation for While async context function + MakeAsync (fun ctxtGuard -> + // One allocation for ctxtLoop reference cell + let mutable ctxtLoop = Unchecked.defaultof<_> + // Two allocations for protected functions + let guardFunc() = ie.MoveNext() + let currentFunc() = ie.Current + // One allocation for ForLoop recursive closure + let rec ForLoop () = + if ctxtGuard.IsCancellationRequested then + ctxtGuard.OnCancellation () + elif ctxtGuard.ProtectCode guardFunc then + let x = ctxtGuard.ProtectCode currentFunc + CallThenInvoke ctxtLoop x computation + else + ctxtGuard.OnSuccess () + // One allocation for loop activation context + ctxtLoop <- ctxtGuard.WithContinuation(ForLoop) + ForLoop ())) +#endif + /// - Initial cancellation check /// - Call syncCtxt.Post with exception protection. THis may fail as it is arbitrary user code let CreateSwitchToAsync (syncCtxt: SynchronizationContext) = From edf0b394b0f340028bcb65b361b3c85ac59df6f9 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 9 Jul 2021 00:18:37 +0100 Subject: [PATCH 8/9] re-enable test fragment --- .../FSharp.Core/Microsoft.FSharp.Control/AsyncModule.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 7dc1fc09c6b..c6718e41863 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 @@ -193,7 +193,7 @@ type AsyncModule() = member this.AwaitIAsyncResult() = let beginOp, endOp, cancelOp = Async.AsBeginEnd(fun() -> getTicksTask) - (* + // Begin the async operation and wait let operationIAR = beginOp ((), new AsyncCallback(fun iar -> ()), null) match Async.AwaitIAsyncResult(operationIAR) |> Async.RunSynchronously with @@ -208,7 +208,7 @@ type AsyncModule() = match result with | true -> () | false -> Assert.Fail("Timed out. Expected to succeed.") - *) + // Now with a timeout let operationIAR = beginOp ((), new AsyncCallback(fun iar -> ()), null) let result = Async.AwaitIAsyncResult(operationIAR, 1) |> Async.RunSynchronously From 7f9cb6f3a666c6935017d127d05700ad4fe83558 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 9 Jul 2021 00:38:39 +0100 Subject: [PATCH 9/9] clean up and document code --- src/fsharp/FSharp.Core/async.fs | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/src/fsharp/FSharp.Core/async.fs b/src/fsharp/FSharp.Core/async.fs index cfdb3a984b2..6fb92fe5c1d 100644 --- a/src/fsharp/FSharp.Core/async.fs +++ b/src/fsharp/FSharp.Core/async.fs @@ -108,13 +108,27 @@ namespace Microsoft.FSharp.Control | Some cont -> storedCont <- None action <- cont - // Let the exception propagate all the way to the trampoline to get a full .StackTrace entry + + // Catch exceptions at the trampoline to get a full .StackTrace entry + // This is because of this problem https://stackoverflow.com/questions/5301535/exception-call-stack-truncated-without-any-re-throwing + // where only a limited number of stack frames are included in the .StackTrace property + // of a .NET exception when it is thrown, up to the first catch handler. + // + // So when running async code, there aren't any intermediate catch handlers (though there + // may be intermediate try/finally frames), there is just this one catch handler at the + // base of the stack. + // + // If an exception is thrown we must have storedExnCont via OnExceptionRaised. with exn -> match storedExnCont with | None -> - // Note, the exception escapes the trampoline. This should not happen since all - // exception-generating code shuld use ProtectCode. - reraise() + // Here, the exception escapes the trampoline. This should not happen since all + // exception-generating code should use ProtectCode. However some + // direct uses of combinators (not using async {...}) may cause + // code to execute unprotected, e.g. async.While((fun () -> failwith ".."), ...) executes the first + // guardExpr unprotected. + reraise() + | Some econt -> storedExnCont <- None let edi = ExceptionDispatchInfo.RestoreOrCapture exn @@ -1453,13 +1467,16 @@ namespace Microsoft.FSharp.Control static member Choice(computations: Async<'T option> seq) : Async<'T option> = MakeAsyncWithCancelCheck (fun ctxt -> + // manually protect eval of seq let result = - try Seq.toArray computations |> Choice1Of2 - with exn -> ExceptionDispatchInfo.RestoreOrCapture exn |> Choice2Of2 + try + Choice1Of2 (Seq.toArray computations) + with exn -> + Choice2Of2 (ExceptionDispatchInfo.RestoreOrCapture exn) match result with | Choice2Of2 edi -> ctxt.econt edi - | Choice1Of2 [||] -> ctxt.cont None + | Choice1Of2 [| |] -> ctxt.cont None | Choice1Of2 computations -> let ctxt = DelimitSyncContext ctxt ctxt.ProtectCode (fun () -> @@ -1605,7 +1622,7 @@ namespace Microsoft.FSharp.Control ctxt.token.Register(Action(fun () -> if latch.Enter() then // Make sure we're not cancelled again - DisposeCancellationRegistration ®istration + DisposeCancellationRegistration ®istration UnregisterWaitHandle &rwh