2 people like it.

Alternative Async.RunSynchronously

An alternative Async.RunSynchronously implementation that avoids the performance bug as recorded in https://github.com/Microsoft/visualfsharp/issues/581

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
open System
open System.Threading
open System.Threading.Tasks

type Async with

    static member RunSynchronously2(workflow : Async<'T>, ?timeout : int, ?cancellationToken : CancellationToken) =
        let tcs = new TaskCompletionSource<'T>()
        match timeout with
        | Some 0 -> raise <| new TimeoutException()
        | Some t when t < 0 -> invalidArg "timeout" "must be positive."
        | Some t -> let timer = new Timer((fun _ -> ignore <| tcs.TrySetException(new TimeoutException())), null, t, Timeout.Infinite) in ()
        | None -> ()

        let start _ = Async.StartWithContinuations(workflow, 
                                                    ignore << tcs.TrySetResult,
                                                    ignore << tcs.TrySetException,
                                                    (fun _ -> ignore <| tcs.TrySetCanceled ()),
                                                    ?cancellationToken = cancellationToken)

        if not <| ThreadPool.QueueUserWorkItem(new WaitCallback(start)) then invalidOp "Could not queue to thread pool." 
        try tcs.Task.Result 
        with :? AggregateException as e when e.InnerExceptions.Count = 1 -> raise e.InnerExceptions.[0]
namespace System
namespace System.Threading
namespace System.Threading.Tasks
Multiple items
type Async
static member AsBeginEnd : computation:('Arg -> Async<'T>) -> ('Arg * AsyncCallback * obj -> IAsyncResult) * (IAsyncResult -> 'T) * (IAsyncResult -> unit)
static member AwaitEvent : event:IEvent<'Del,'T> * ?cancelAction:(unit -> unit) -> Async<'T> (requires delegate and 'Del :> Delegate)
static member AwaitIAsyncResult : iar:IAsyncResult * ?millisecondsTimeout:int -> Async<bool>
static member AwaitTask : task:Task<'T> -> Async<'T>
static member AwaitWaitHandle : waitHandle:WaitHandle * ?millisecondsTimeout:int -> Async<bool>
static member CancelDefaultToken : unit -> unit
static member Catch : computation:Async<'T> -> Async<Choice<'T,exn>>
static member FromBeginEnd : beginAction:(AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg:'Arg1 * beginAction:('Arg1 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * beginAction:('Arg1 * 'Arg2 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromBeginEnd : arg1:'Arg1 * arg2:'Arg2 * arg3:'Arg3 * beginAction:('Arg1 * 'Arg2 * 'Arg3 * AsyncCallback * obj -> IAsyncResult) * endAction:(IAsyncResult -> 'T) * ?cancelAction:(unit -> unit) -> Async<'T>
static member FromContinuations : callback:(('T -> unit) * (exn -> unit) * (OperationCanceledException -> unit) -> unit) -> Async<'T>
static member Ignore : computation:Async<'T> -> Async<unit>
static member OnCancel : interruption:(unit -> unit) -> Async<IDisposable>
static member Parallel : computations:seq<Async<'T>> -> Async<'T []>
static member RunSynchronously : computation:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T
static member Sleep : millisecondsDueTime:int -> Async<unit>
static member Start : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions * ?cancellationToken:CancellationToken -> Task<'T>
static member StartChild : computation:Async<'T> * ?millisecondsTimeout:int -> Async<Async<'T>>
static member StartChildAsTask : computation:Async<'T> * ?taskCreationOptions:TaskCreationOptions -> Async<Task<'T>>
static member StartImmediate : computation:Async<unit> * ?cancellationToken:CancellationToken -> unit
static member StartWithContinuations : computation:Async<'T> * continuation:('T -> unit) * exceptionContinuation:(exn -> unit) * cancellationContinuation:(OperationCanceledException -> unit) * ?cancellationToken:CancellationToken -> unit
static member SwitchToContext : syncContext:SynchronizationContext -> Async<unit>
static member SwitchToNewThread : unit -> Async<unit>
static member SwitchToThreadPool : unit -> Async<unit>
static member TryCancelled : computation:Async<'T> * compensation:(OperationCanceledException -> unit) -> Async<'T>
static member CancellationToken : Async<CancellationToken>
static member DefaultCancellationToken : CancellationToken

Full name: Microsoft.FSharp.Control.Async

--------------------
type Async<'T>

Full name: Microsoft.FSharp.Control.Async<_>
static member Async.RunSynchronously2 : workflow:Async<'T> * ?timeout:int * ?cancellationToken:CancellationToken -> 'T

Full name: Script.RunSynchronously2
val workflow : Async<'T>
val timeout : int option
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
val cancellationToken : CancellationToken option
Multiple items
type CancellationToken =
  struct
    new : canceled:bool -> CancellationToken
    member CanBeCanceled : bool
    member Equals : other:CancellationToken -> bool + 1 overload
    member GetHashCode : unit -> int
    member IsCancellationRequested : bool
    member Register : callback:Action -> CancellationTokenRegistration + 3 overloads
    member ThrowIfCancellationRequested : unit -> unit
    member WaitHandle : WaitHandle
    static member None : CancellationToken
  end

Full name: System.Threading.CancellationToken

--------------------
CancellationToken()
CancellationToken(canceled: bool) : unit
val tcs : TaskCompletionSource<'T>
Multiple items
type TaskCompletionSource<'TResult> =
  new : unit -> TaskCompletionSource<'TResult> + 3 overloads
  member SetCanceled : unit -> unit
  member SetException : exception:Exception -> unit + 1 overload
  member SetResult : result:'TResult -> unit
  member Task : Task<'TResult>
  member TrySetCanceled : unit -> bool
  member TrySetException : exception:Exception -> bool + 1 overload
  member TrySetResult : result:'TResult -> bool

Full name: System.Threading.Tasks.TaskCompletionSource<_>

--------------------
TaskCompletionSource() : unit
TaskCompletionSource(creationOptions: TaskCreationOptions) : unit
TaskCompletionSource(state: obj) : unit
TaskCompletionSource(state: obj, creationOptions: TaskCreationOptions) : unit
union case Option.Some: Value: 'T -> Option<'T>
val raise : exn:Exception -> 'T

Full name: Microsoft.FSharp.Core.Operators.raise
Multiple items
type TimeoutException =
  inherit SystemException
  new : unit -> TimeoutException + 2 overloads

Full name: System.TimeoutException

--------------------
TimeoutException() : unit
TimeoutException(message: string) : unit
TimeoutException(message: string, innerException: exn) : unit
val t : int
val invalidArg : argumentName:string -> message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidArg
val timer : Timer
Multiple items
type Timer =
  inherit MarshalByRefObject
  new : callback:TimerCallback -> Timer + 4 overloads
  member Change : dueTime:int * period:int -> bool + 3 overloads
  member Dispose : unit -> unit + 1 overload

Full name: System.Threading.Timer

--------------------
Timer(callback: TimerCallback) : unit
Timer(callback: TimerCallback, state: obj, dueTime: int, period: int) : unit
Timer(callback: TimerCallback, state: obj, dueTime: TimeSpan, period: TimeSpan) : unit
Timer(callback: TimerCallback, state: obj, dueTime: uint32, period: uint32) : unit
Timer(callback: TimerCallback, state: obj, dueTime: int64, period: int64) : unit
val ignore : value:'T -> unit

Full name: Microsoft.FSharp.Core.Operators.ignore
TaskCompletionSource.TrySetException(exceptions: Collections.Generic.IEnumerable<exn>) : bool
TaskCompletionSource.TrySetException(exception: exn) : bool
type Timeout =
  static val Infinite : int

Full name: System.Threading.Timeout
field Timeout.Infinite = -1
union case Option.None: Option<'T>
val start : ('a -> unit)
static member Async.StartWithContinuations : computation:Async<'T> * continuation:('T -> unit) * exceptionContinuation:(exn -> unit) * cancellationContinuation:(OperationCanceledException -> unit) * ?cancellationToken:CancellationToken -> unit
TaskCompletionSource.TrySetResult(result: 'T) : bool
TaskCompletionSource.TrySetCanceled() : bool
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
type ThreadPool =
  static member BindHandle : osHandle:nativeint -> bool + 1 overload
  static member GetAvailableThreads : workerThreads:int * completionPortThreads:int -> unit
  static member GetMaxThreads : workerThreads:int * completionPortThreads:int -> unit
  static member GetMinThreads : workerThreads:int * completionPortThreads:int -> unit
  static member QueueUserWorkItem : callBack:WaitCallback -> bool + 1 overload
  static member RegisterWaitForSingleObject : waitObject:WaitHandle * callBack:WaitOrTimerCallback * state:obj * millisecondsTimeOutInterval:uint32 * executeOnlyOnce:bool -> RegisteredWaitHandle + 3 overloads
  static member SetMaxThreads : workerThreads:int * completionPortThreads:int -> bool
  static member SetMinThreads : workerThreads:int * completionPortThreads:int -> bool
  static member UnsafeQueueNativeOverlapped : overlapped:NativeOverlapped -> bool
  static member UnsafeQueueUserWorkItem : callBack:WaitCallback * state:obj -> bool
  ...

Full name: System.Threading.ThreadPool
ThreadPool.QueueUserWorkItem(callBack: WaitCallback) : bool
ThreadPool.QueueUserWorkItem(callBack: WaitCallback, state: obj) : bool
type WaitCallback =
  delegate of obj -> unit

Full name: System.Threading.WaitCallback
val invalidOp : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidOp
property TaskCompletionSource.Task: Task<'T>
property Task.Result: 'T
Multiple items
type AggregateException =
  inherit Exception
  new : unit -> AggregateException + 6 overloads
  member Flatten : unit -> AggregateException
  member GetBaseException : unit -> Exception
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member Handle : predicate:Func<Exception, bool> -> unit
  member InnerExceptions : ReadOnlyCollection<Exception>
  member ToString : unit -> string

Full name: System.AggregateException

--------------------
AggregateException() : unit
AggregateException(message: string) : unit
AggregateException(innerExceptions: Collections.Generic.IEnumerable<exn>) : unit
AggregateException([<ParamArray>] innerExceptions: exn []) : unit
AggregateException(message: string, innerException: exn) : unit
AggregateException(message: string, innerExceptions: Collections.Generic.IEnumerable<exn>) : unit
AggregateException(message: string, [<ParamArray>] innerExceptions: exn []) : unit
val e : AggregateException
property AggregateException.InnerExceptions: Collections.ObjectModel.ReadOnlyCollection<exn>
property Collections.ObjectModel.ReadOnlyCollection.Count: int
Raw view Test code New version

More information

Link:http://fssnip.net/sl
Posted:8 years ago
Author:Eirik Tsarpalis
Tags: async