#if FX_NO_CANCELLATIONTOKEN_CLASSES

open System

open Microsoft.FSharp.Core

open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators

open Microsoft.FSharp.Core.Operators

open Microsoft.FSharp.Control

open Microsoft.FSharp.Collections

type [<Class>] AggregateException (exns : seq<exn>) =

inherit Exception()

let exnsList = new System.Collections.Generic.List<exn>(exns)

member this.InnerExceptions = new System.Collections.ObjectModel.ReadOnlyCollection<exn>(exnsList :> System.Collections.Generic.IList<exn>)

#nowarn "864" // this is for typed Equals() in CancellationTokenRegistration and CancellationToken

open System

open Microsoft.FSharp.Core

open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators

open Microsoft.FSharp.Core.Operators

open Microsoft.FSharp.Control

open Microsoft.FSharp.Collections

module internal CancellationState =

[<Literal>]

let ACTIVE = 0

[<Literal>]

let DISPOSED_ACTIVE = 1

[<Literal>]

let CANCELED = 2

[<Literal>]

let DISPOSED_CANCELED = 3

[<Struct>]

[<CustomEquality; NoComparison>]

type CancellationTokenRegistration =

val private source : CancellationTokenSource

val private id : int64

internal new(source,id) = { source = source; id = id }

member this.Dispose() =

match this.source with

| null -> ()

| _ -> this.source.Deregister(this.id)

member this.Equals(ctr:CancellationTokenRegistration) =

match this.source with

| null -> isNull ctr.source

| _ -> this.source.Equals(ctr.source) && this.id = ctr.id

override this.Equals(o:obj) =

match o with

| :? CancellationTokenRegistration as ctr -> this.Equals(ctr)

| _ -> false

override this.GetHashCode() =

match this.source with

| null -> 0

| _ -> this.source.GetHashCode()^^^this.id.GetHashCode()

static member (=) (left:CancellationTokenRegistration,right:CancellationTokenRegistration) = left.Equals(right)

static member (<>) (left:CancellationTokenRegistration,right:CancellationTokenRegistration) = not (left.Equals(right))

interface System.IDisposable with

member this.Dispose() = this.Dispose()

and [<Struct>]

[<CustomEquality; NoComparison>]

CancellationToken =

val private source : CancellationTokenSource

internal new (source) = { source = source }

member this.IsCancellationRequested =

match this.source with

| null -> false

| source -> source.IsCancellationRequested

member this.CanBeCanceled = this.source <> Unchecked.defaultof<_>

member this.Register (action:Action<obj>, state:obj) =

match this.source with

| null -> Unchecked.defaultof<_>

| source -> source.Register(action, state)

member this.Equals(ct:CancellationToken) =

match this.source with

| null -> isNull ct.source

| _ -> this.source.Equals(ct.source)

override this.Equals(o:obj) =

match o with

| :? CancellationToken as ct -> this.Equals(ct)

| _ -> false

override this.GetHashCode() =

match this.source with

| null -> 0

| _ -> this.source.GetHashCode()

static member (=) (left:CancellationToken,right:CancellationToken) = left.Equals(right)

static member (<>) (left:CancellationToken,right:CancellationToken) = not (left.Equals(right))

static member None = new CancellationToken(null)

and [<Struct>]

[<NoEquality; NoComparison>]

internal CallbackInfo =

val private id : int64

val private action : Action<obj>

val private state : obj

new (id,action,state) = { id = id; action = action; state = state }

member this.ID = this.id

member this.Action = this.action

member this.State = this.state

and [<Class>][<Sealed>][<AllowNullLiteral>]

CancellationTokenSource private (token1 : CancellationToken, token2 : CancellationToken) as this =

[<VolatileField>]

let mutable state = CancellationState.ACTIVE

// next registration id

let mutable nextID = 0L;

// lazily initialized list of registrations

let registrations = lazy (new System.Collections.Generic.List<CallbackInfo>())

// linking to tokens

let mutable linkedCtr1 = Unchecked.defaultof<CancellationTokenRegistration>

let mutable linkedCtr2 = Unchecked.defaultof<CancellationTokenRegistration>

do

let handler = Action<obj>(fun _ ->

// Avoinding a race for Dispose versus Cancel for linked token sources:

// - CTS.Dispose deregisters its CTRs and sets state to DISPOSED_*

// - However if the cancellation is in progress in the source it is linked to, deregistration is a no-op and CTS may still receive cancellation notification

// - That cancellation notification arrives in disposed state

// We ignore cancellation notifications from linked sources in disposed state (so if cancellation/disposal race happens, disposal wins).

this.Cancel(dontThrowIfDisposed = true)

)

linkedCtr1 <- token1.Register(handler,null)

linkedCtr2 <- token2.Register(handler,null)

public new() = new CancellationTokenSource(Unchecked.defaultof<_>,Unchecked.defaultof<_>)

member this.Token = new CancellationToken(this)

member this.Cancel() = this.Cancel(dontThrowIfDisposed = false)

member private this.Cancel (dontThrowIfDisposed) : unit =

let oldState = Interlocked.CompareExchange(&state, CancellationState.CANCELED, CancellationState.ACTIVE)

match oldState with

| CancellationState.ACTIVE ->

if registrations.IsValueCreated then // we have at least one registration

let list = registrations.Value

let toRun =

// building a list of callback to run, in LIFO order

lock list (fun () ->

let toRun = list |> Seq.fold (fun l info -> (fun () -> info.Action.Invoke(info.State))::l) []

list.Clear()

toRun)

let doRun l f = // run callback, add any thrown exception to the list

try f(); l

with e -> e::l

let exns = List.fold doRun [] toRun

match exns with

| [] -> ()

| _ ->

// exns are in reverse order to the callbacks in toRun

// we rev here; mainline case (no exceptions at all) runs without any allocations for exception list

new AggregateException(exns |> List.rev) |> raise

else () // no registrations - do nothing

| CancellationState.CANCELED ->

() // cancellation already happened

| _ ->

// DISPOSED_ACTIVE or DISPOSED_CANCELED

if not dontThrowIfDisposed then

new ObjectDisposedException(typeof<CancellationTokenSource>.FullName) |> raise

else ()

member this.Dispose() =

try

// Unregister from linked sources before changing state. Otherwise callback may still execute and we will be canceled in disposed state

// Multiple CTR disposal is a no-op

try

linkedCtr2.Dispose()

finally

linkedCtr1.Dispose()

finally

let disposeNow =

let oldState = Interlocked.CompareExchange(&state, CancellationState.DISPOSED_ACTIVE, CancellationState.ACTIVE)

if oldState = CancellationState.ACTIVE then

true // previous state was ACTIVE, now disposing

else

let oldState = Interlocked.CompareExchange(&state, CancellationState.DISPOSED_CANCELED, CancellationState.CANCELED)

// if previous state was CANCELED, dispose now. Otherwise previous state was one of DISPOSED_* states, so already disposed

oldState = CancellationState.CANCELED

if disposeNow then

if registrations.IsValueCreated then

let list = registrations.Value

lock list (fun () -> list.Clear())

member private this.InternalIsCanceled throwOnDisposed =

match state with

| CancellationState.ACTIVE -> false

| CancellationState.CANCELED -> true

| CancellationState.DISPOSED_CANCELED ->

if throwOnDisposed then

new ObjectDisposedException(typeof<CancellationTokenSource>.FullName) |> raise

else

true

| _ ->

if throwOnDisposed then

new ObjectDisposedException(typeof<CancellationTokenSource>.FullName) |> raise

else

false

member internal this.IsCancellationRequested = state = CancellationState.CANCELED || state = CancellationState.DISPOSED_CANCELED

member internal this.Register(action:Action<obj>, state:obj) =

if this.InternalIsCanceled true then // do not register, invoke immediately

action.Invoke(state)

Unchecked.defaultof<_>

else

let list = registrations.Value

let invokeNow, r =

lock list (fun () ->

if this.InternalIsCanceled true then

true, new CancellationTokenRegistration(Unchecked.defaultof<_>, 0L)

else

let id = nextID

nextID <- nextID + 1L

list.Add(new CallbackInfo(id, action, state))

false, new CancellationTokenRegistration(this, id)

)

if invokeNow then action.Invoke(state)

r

member internal this.Deregister(id) =

if this.InternalIsCanceled false then // ok to deregister after Dispose

() // After cancellation is requested no deregistration needed;

else

let list = registrations.Value

lock list (fun () ->

if this.InternalIsCanceled false then // ok to deregister after Dispose

()

else

let index =

// Search backwards; we assume Register/Deregister are scoped

// so registered last will be deregistred first

let rec loop i =

if i < 0 then (-1)

else

let callbackInfo = list.[i]

if callbackInfo.ID = id then i

else loop (i-1)

loop (list.Count - 1)

if index >= 0 then

list.RemoveAt(index)

else

() // we do not punish double deregistering

)

interface System.IDisposable with

member this.Dispose() = this.Dispose()

static member CreateLinkedTokenSource (token1:CancellationToken,token2:CancellationToken) =

new CancellationTokenSource(token1,token2)

#nowarn "40"

#nowarn "21"

#nowarn "47"

#nowarn "52" // The value has been copied to ensure the original is not mutated by this operation

#nowarn "67" // This type test or downcast will always hold

#nowarn "864" // IObservable.Subscribe

open System

open System.Diagnostics

open System.Diagnostics.CodeAnalysis

open System.IO

open System.Reflection

open System.Threading

open Microsoft.FSharp.Core

open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators

open Microsoft.FSharp.Core.Operators

open Microsoft.FSharp.Control

open Microsoft.FSharp.Collections

#if FX_RESHAPED_REFLECTION

open ReflectionAdapters

#if !FX_NO_TASK

open System.Threading

open System.Threading.Tasks

#if FX_NO_OPERATION_CANCELLED

type OperationCanceledException(s : System.String) =

inherit System.Exception(s)

new () = new OperationCanceledException("The operation has been canceled")

#if FX_NO_EXCEPTIONDISPATCHINFO

[<AllowNullLiteral>]

type ExceptionDispatchInfo(exn: System.Exception) =

static member Capture(exn) = ExceptionDispatchInfo(exn)

member __.Throw() = raise exn; ()

member __.SourceException = exn

open System.Runtime.ExceptionServices

/// We use our own internal implementation of queues to avoid a dependency on System.dll

type Queue<'T>() = //: IEnumerable<T>, ICollection, IEnumerable

let mutable array = [| |]

let mutable head = 0

let mutable size = 0

let mutable tail = 0

let SetCapacity(capacity) =

let destinationArray = Array.zeroCreate capacity;

if (size > 0) then

if (head < tail) then

System.Array.Copy(array, head, destinationArray, 0, size);

else

System.Array.Copy(array, head, destinationArray, 0, array.Length - head);

System.Array.Copy(array, 0, destinationArray, array.Length - head, tail);

array <- destinationArray;

head <- 0;

tail <- if (size = capacity) then 0 else size;

member x.Dequeue() =

if (size = 0) then

failwith "Dequeue"

let local = array.[head];

array.[head] <- Unchecked.defaultof<'T>

head <- (head + 1) % array.Length;

size <- size - 1;

local

member this.Enqueue(item) =

if (size = array.Length) then

let capacity = int ((int64 array.Length * 200L) / 100L);

let capacity = max capacity (array.Length + 4)

SetCapacity(capacity);

array.[tail] <- item;

tail <- (tail + 1) % array.Length;

size <- size + 1

member x.Count = size

type LinkedSubSource(ct : CancellationToken) =

let failureCTS = new CancellationTokenSource()

let linkedCTS = CancellationTokenSource.CreateLinkedTokenSource(ct, failureCTS.Token)

member this.Token = linkedCTS.Token

member this.Cancel() = failureCTS.Cancel()

member this.Dispose() =

linkedCTS.Dispose()

failureCTS.Dispose()

interface IDisposable with

member this.Dispose() = this.Dispose()

// F# don't always take tailcalls to functions returning 'unit' because this

// is represented as type 'void' in the underlying IL.

// Hence we don't use the 'unit' return type here, and instead invent our own type.

[<NoEquality; NoComparison>]

type FakeUnitValue =

| FakeUnit

type cont<'T> = ('T -> FakeUnitValue)

type econt = (ExceptionDispatchInfo -> FakeUnitValue)

type ccont = (OperationCanceledException -> FakeUnitValue)

//----------------------------------

// PRIMITIVE ASYNC TRAMPOLINE

[<AllowNullLiteral>]

type Trampoline() =

[<Literal>]

static let bindLimitBeforeHijack = 300

#if !FX_NO_THREAD_STATIC

[<ThreadStatic>]

[<DefaultValue>]

static val mutable private thisThreadHasTrampoline : bool

static member ThisThreadHasTrampoline =

#if FX_NO_THREAD_STATIC

true

Trampoline.thisThreadHasTrampoline

let mutable cont = None

let mutable bindCount = 0

static let unfake FakeUnit = ()

// Install a trampolineStack if none exists

member this.ExecuteAction (firstAction : unit -> FakeUnitValue) =

let rec loop action =

action() |> unfake

match cont with

| None -> ()

| Some newAction ->

cont <- None

loop newAction

#if !FX_NO_THREAD_STATIC

let thisIsTopTrampoline =

if Trampoline.thisThreadHasTrampoline then

false

else

Trampoline.thisThreadHasTrampoline <- true

true

try

loop firstAction

finally

#if FX_NO_THREAD_STATIC

()

if thisIsTopTrampoline then

Trampoline.thisThreadHasTrampoline <- false

#endif

FakeUnit

// returns true if time to jump on trampoline

member this.IncrementBindCount() =

bindCount <- bindCount + 1

bindCount >= bindLimitBeforeHijack

member this.Set action =

match cont with

| None ->

bindCount <- 0

cont <- Some action

| _ -> failwith "Internal error: attempting to install continuation twice"

#if FSCORE_PORTABLE_NEW

// Imitation of desktop functionality for .NETCore

// 1. QueueUserWorkItem reimplemented as Task.Run

// 2. Thread.CurrentThread type in the code is typically used to check if continuation is called on the same thread that initiated the async computation

// if this condition holds we may decide to invoke continuation directly rather than queueing it.

// Thread type here is barely a wrapper over CurrentManagedThreadId value - it should be enough to uniquely identify the actual thread

[<NoComparison; NoEquality>]

type internal WaitCallback = WaitCallback of (obj -> unit)

type ThreadPool =

static member QueueUserWorkItem(WaitCallback(cb), state : obj) =

System.Threading.Tasks.Task.Run (fun () -> cb(state)) |> ignore

true

[<AllowNullLiteral>]

type Thread(threadId : int) =

static member CurrentThread = Thread(Environment.CurrentManagedThreadId)

member this.ThreadId = threadId

override this.GetHashCode() = threadId

override this.Equals(other : obj) =

match other with

| :? Thread as other -> threadId = other.ThreadId

| _ -> false

type TrampolineHolder() as this =

let mutable trampoline = null

static let unfake FakeUnit = ()

// preallocate context-switching callbacks

#if !FX_NO_SYNC_CONTEXT

// Preallocate the delegate

// This should be the only call to SynchronizationContext.Post in this library. We must always install a trampoline.

let sendOrPostCallback =

SendOrPostCallback(fun o ->

let f = unbox o : unit -> FakeUnitValue

this.Protect f |> unfake

)

// Preallocate the delegate

// This should be the only call to QueueUserWorkItem in this library. We must always install a trampoline.

let waitCallbackForQueueWorkItemWithTrampoline =

WaitCallback(fun o ->

let f = unbox o : unit -> FakeUnitValue

this.Protect f |> unfake

)

#if !FX_NO_PARAMETERIZED_THREAD_START

// This should be the only call to Thread.Start in this library. We must always install a trampoline.

let threadStartCallbackForStartThreadWithTrampoline =

ParameterizedThreadStart(fun o ->

let f = unbox o : unit -> FakeUnitValue

this.Protect f |> unfake

)

#if !FX_NO_SYNC_CONTEXT

member this.Post (ctxt: SynchronizationContext) (f : unit -> FakeUnitValue) =

ctxt.Post (sendOrPostCallback, state=(f |> box))

FakeUnit

member this.QueueWorkItem (f: unit -> FakeUnitValue) =

if not (ThreadPool.QueueUserWorkItem(waitCallbackForQueueWorkItemWithTrampoline, f |> box)) then

failwith "failed to queue user work item"

FakeUnit

#if FX_NO_PARAMETERIZED_THREAD_START

// This should be the only call to Thread.Start in this library. We must always install a trampoline.

member this.StartThread (f : unit -> FakeUnitValue) =

#if FX_NO_THREAD

this.QueueWorkItem(f)

(new Thread((fun _ -> this.Protect f |> unfake), IsBackground=true)).Start()

FakeUnit

// This should be the only call to Thread.Start in this library. We must always install a trampoline.

member this.StartThread (f : unit -> FakeUnitValue) =

(new Thread(threadStartCallbackForStartThreadWithTrampoline,IsBackground=true)).Start(f|>box)

FakeUnit

member this.Protect firstAction =

trampoline <- new Trampoline()

trampoline.ExecuteAction(firstAction)

member this.Trampoline = trampoline

[<NoEquality; NoComparison>]

[<AutoSerializable(false)>]

type AsyncParamsAux =

{ token : CancellationToken;

econt : econt;

ccont : ccont;

trampolineHolder : TrampolineHolder

}

[<NoEquality; NoComparison>]

[<AutoSerializable(false)>]

type AsyncParams<'T> =

{ cont : cont<'T>

aux : AsyncParamsAux

}

[<NoEquality; NoComparison>]

[<CompiledName("FSharpAsync`1")>]

type Async<'T> =

P of (AsyncParams<'T> -> FakeUnitValue)

module AsyncBuilderImpl =

// To consider: augment with more exception traceability information

// To consider: add the ability to suspend running ps in debug mode

// To consider: add the ability to trace running ps in debug mode

open System

open System.Threading

open System.IO

open Microsoft.FSharp.Core

let fake () = FakeUnit

let unfake FakeUnit = ()

let ignoreFake _ = FakeUnit

let mutable defaultCancellationTokenSource = new CancellationTokenSource()

[<NoEquality; NoComparison>]

type AsyncImplResult<'T> =

| Ok of 'T

| Error of ExceptionDispatchInfo

| Canceled of OperationCanceledException

let inline hijack (trampolineHolder:TrampolineHolder) res (cont : 'T -> FakeUnitValue) : FakeUnitValue =

if trampolineHolder.Trampoline.IncrementBindCount() then

trampolineHolder.Trampoline.Set(fun () -> cont res)

FakeUnit

else

// NOTE: this must be a tailcall

cont res

#if !FX_NO_CONDITIONAL_WEAK_TABLE

/// Global mutable state used to associate Exception

let associationTable = System.Runtime.CompilerServices.ConditionalWeakTable<exn, ExceptionDispatchInfo>()

type ExceptionDispatchInfo with

member edi.GetAssociatedSourceException() =

let exn = edi.SourceException

#if !FX_NO_CONDITIONAL_WEAK_TABLE

// Try to store the entry in the association table to allow us to recover it later.

try lock associationTable (fun () -> associationTable.Add(exn, edi)) with _ -> ()

exn

// Capture, but prefer the saved information if available

static member inline RestoreOrCapture(exn) =

#if !FX_NO_CONDITIONAL_WEAK_TABLE

match lock associationTable (fun () -> associationTable.TryGetValue(exn)) with

| true, edi -> edi

| _ ->

ExceptionDispatchInfo.Capture(exn)

member inline edi.ThrowAny() =

edi.Throw()

Unchecked.defaultof<'T> // Note, this line should not be reached, but gives a generic return type

// Apply f to x and call either the continuation or exception continuation depending what happens

let inline protect (trampolineHolder:TrampolineHolder) econt f x (cont : 'T -> FakeUnitValue) : FakeUnitValue =

// This is deliberately written in a allocation-free style, except when the trampoline is taken

let mutable res = Unchecked.defaultof<_>

let mutable edi = null

try

res <- f x

with exn ->

edi <- ExceptionDispatchInfo.RestoreOrCapture(exn)

match edi with

| null ->

// NOTE: this must be a tailcall

hijack trampolineHolder res cont

| _ ->

// NOTE: this must be a tailcall

hijack trampolineHolder edi econt

// Apply f to x and call either the continuation or exception continuation depending what happens

let inline protectNoHijack econt f x (cont : 'T -> FakeUnitValue) : FakeUnitValue =

// This is deliberately written in a allocation-free style

let mutable res = Unchecked.defaultof<_>

let mutable edi = null

try

res <- f x

with exn ->

edi <- ExceptionDispatchInfo.RestoreOrCapture(exn)

match edi with

| null ->

// NOTE: this must be a tailcall

cont res

| exn ->

// NOTE: this must be a tailcall

econt exn

// Reify exceptional results as exceptions

let commit res =

match res with

| Ok res -> res

| Error edi -> edi.ThrowAny()

| Canceled exn -> raise exn

// Reify exceptional results as exceptionsJIT 64 doesn't always take tailcalls correctly

let commitWithPossibleTimeout res =

match res with

| None -> raise (System.TimeoutException())

| Some res -> commit res

//----------------------------------

// PRIMITIVE ASYNC INVOCATION

// Apply the underlying implementation of an async computation to its inputs

let inline invokeA (P pf) args = pf args

let startA cancellationToken trampolineHolder cont econt ccont p =

let args =

{ cont = cont

aux = { token = cancellationToken;

econt = econt

ccont = ccont

trampolineHolder = trampolineHolder

}

}

invokeA p args

#if FX_NO_PARAMETERIZED_THREAD_START

// Preallocate the delegate

// This should be the only call to QueueUserWorkItem in this library. We must always install a trampoline.

let waitCallbackForQueueWorkItemWithTrampoline(trampolineHolder : TrampolineHolder) =

WaitCallback(fun o ->

let f = unbox o : unit -> FakeUnitValue

trampolineHolder.Protect f |> unfake

)

let startThreadWithTrampoline (trampolineHolder:TrampolineHolder) (f : unit -> FakeUnitValue) =

#if FX_NO_THREAD

if not (ThreadPool.QueueUserWorkItem((waitCallbackForQueueWorkItemWithTrampoline trampolineHolder), f |> box)) then

failwith "failed to queue user work item"

FakeUnit

#else

(new Thread((fun _ -> trampolineHolder.Protect f |> unfake), IsBackground=true)).Start()

FakeUnit

#endif

// Statically preallocate the delegate

let threadStartCallbackForStartThreadWithTrampoline =

ParameterizedThreadStart(fun o ->

let (trampolineHolder,f) = unbox o : TrampolineHolder * (unit -> FakeUnitValue)

trampolineHolder.Protect f |> unfake

)

// This should be the only call to Thread.Start in this library. We must always install a trampoline.

let startThreadWithTrampoline (trampolineHolder:TrampolineHolder) (f : unit -> FakeUnitValue) =

(new Thread(threadStartCallbackForStartThreadWithTrampoline,IsBackground=true)).Start((trampolineHolder,f)|>box)

FakeUnit

let startAsync cancellationToken cont econt ccont p =

let trampolineHolder = new TrampolineHolder()

trampolineHolder.Protect (fun () -> startA cancellationToken trampolineHolder cont econt ccont p)

let queueAsync cancellationToken cont econt ccont p =

let trampolineHolder = new TrampolineHolder()

trampolineHolder.QueueWorkItem(fun () -> startA cancellationToken trampolineHolder cont econt ccont p)

//----------------------------------

// PRIMITIVE ASYNC CONSTRUCTORS

// Use this to recover ExceptionDispatchInfo when outside the "with" part of a try/with block.

// This indicates all the places where we lose a stack trace.

//

// Stack trace losses come when interoperating with other code that only provide us with an exception value,

// notably .NET 4.x tasks and user exceptions passed to the exception continuation in Async.FromContinuations.

let MayLoseStackTrace exn = ExceptionDispatchInfo.RestoreOrCapture(exn)

// Call the exception continuation

let errorT args edi =

args.aux.econt edi

// Call the cancellation continuation

let cancelT (args:AsyncParams<_>) =

args.aux.ccont (new OperationCanceledException())

// Build a primitive without any exception of resync protection

//

// Use carefully!!

let unprotectedPrimitive f = P f

let protectedPrimitiveCore args f =

if args.aux.token.IsCancellationRequested then

cancelT args

else

try

f args

with exn ->

let edi = ExceptionDispatchInfo.RestoreOrCapture(exn)

errorT args edi

// When run, ensures that any exceptions raised by the immediate execution of "f" are

// sent to the exception continuation.

//

let protectedPrimitive f =

unprotectedPrimitive (fun args -> protectedPrimitiveCore args f)

let reify res =

unprotectedPrimitive (fun args ->

match res with

| AsyncImplResult.Ok r -> args.cont r

| AsyncImplResult.Error e -> args.aux.econt e

| AsyncImplResult.Canceled oce -> args.aux.ccont oce)

//----------------------------------

// BUILDER OPREATIONS

// Generate async computation which calls its continuation with the given result

let resultA x =

unprotectedPrimitive (fun ({ aux = aux } as args) ->

if aux.token.IsCancellationRequested then

cancelT args

else

hijack aux.trampolineHolder x args.cont)

// 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

let bindA p1 f =

unprotectedPrimitive (fun args ->

if args.aux.token.IsCancellationRequested then

cancelT args

else

let args =

let cont a = protectNoHijack args.aux.econt f a (fun p2 -> invokeA p2 args)

{ cont=cont;

aux = args.aux

}

// Trampoline the continuation onto a new work item every so often

let trampoline = args.aux.trampolineHolder.Trampoline

if trampoline.IncrementBindCount() then

trampoline.Set(fun () -> invokeA p1 args)

FakeUnit

else

// NOTE: this must be a tailcall

invokeA p1 args)

// callA = "bindA (return x) f"

let callA f x =

unprotectedPrimitive (fun args ->

if args.aux.token.IsCancellationRequested then

cancelT args

else

protect args.aux.trampolineHolder args.aux.econt f x (fun p2 -> invokeA p2 args)

)

// delayPrim = "bindA (return ()) f"

let delayA f = callA f ()

// Call p but augment the normal, exception and cancel continuations with a call to finallyFunction.

// If the finallyFunction raises an exception then call the original exception continuation

// with the new exception. If exception is raised after a cancellation, exception is ignored

// and cancel continuation is called.

let tryFinallyA finallyFunction p =

unprotectedPrimitive (fun args ->

if args.aux.token.IsCancellationRequested then

cancelT args

else

let trampolineHolder = args.aux.trampolineHolder

// 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 b = protect trampolineHolder args.aux.econt finallyFunction () (fun () -> args.cont b)

// 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 = protect trampolineHolder args.aux.econt finallyFunction () (fun () -> args.aux.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 = protect trampolineHolder (fun _ -> args.aux.ccont cexn) finallyFunction () (fun () -> args.aux.ccont cexn)

invokeA p { args with cont = cont; aux = { args.aux with econt = econt; ccont = ccont } })

// Re-route the exception continuation to call to catchFunction. If catchFunction or the new process fail

// then call the original exception continuation with the failure.

let tryWithDispatchInfoA catchFunction p =

unprotectedPrimitive (fun args ->

if args.aux.token.IsCancellationRequested then

cancelT args

else

let econt (edi: ExceptionDispatchInfo) = invokeA (callA catchFunction edi) args

invokeA p { args with aux = { args.aux with econt = econt } })

let tryWithExnA catchFunction computation =

computation |> tryWithDispatchInfoA (fun edi -> catchFunction (edi.GetAssociatedSourceException()))

/// Call the finallyFunction if the computation results in a cancellation

let whenCancelledA (finallyFunction : OperationCanceledException -> unit) p =

unprotectedPrimitive (fun ({ aux = aux } as args)->

let ccont exn = protect aux.trampolineHolder (fun _ -> aux.ccont exn) finallyFunction exn (fun _ -> aux.ccont exn)

invokeA p { args with aux = { aux with ccont = ccont } })

let getCancellationToken() =

unprotectedPrimitive (fun ({ aux = aux } as args) -> args.cont aux.token)

let getTrampolineHolder() =

unprotectedPrimitive (fun ({ aux = aux } as args) -> args.cont aux.trampolineHolder)

/// Return a unit result

let doneA =

resultA()

/// Implement use/Dispose

let usingA (r:'T :> IDisposable) (f:'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 r

tryFinallyA disposeFunction (callA f r) |> whenCancelledA disposeFunction

let ignoreA p =

bindA p (fun _ -> doneA)

/// Implement the while loop

let rec whileA gd prog =

if gd() then

bindA prog (fun () -> whileA gd prog)

else

doneA

/// Implement the for loop

let rec forA (e: seq<_>) prog =

usingA (e.GetEnumerator()) (fun ie ->

whileA

(fun () -> ie.MoveNext())

(delayA(fun () -> prog ie.Current)))

let sequentialA p1 p2 =

bindA p1 (fun () -> p2)

open AsyncBuilderImpl

[<Sealed>]

[<CompiledName("FSharpAsyncBuilder")>]

type AsyncBuilder() =

member b.Zero() = doneA

member b.Delay(f) = delayA(f)

member b.Return(x) = resultA(x)

member b.ReturnFrom(x:Async<_>) = x

member b.Bind(p1, p2) = bindA p1 p2

member b.Using(g, p) = usingA g p

member b.While(gd, prog) = whileA gd prog

member b.For(e, prog) = forA e prog

member b.Combine(p1, p2) = sequentialA p1 p2

member b.TryFinally(p, cf) = tryFinallyA cf p

member b.TryWith(p, cf) = tryWithExnA cf p

module AsyncImpl =

let async = AsyncBuilder()

//----------------------------------

// DERIVED SWITCH TO HELPERS

#if !FX_NO_SYNC_CONTEXT

let switchTo (ctxt: SynchronizationContext) =

protectedPrimitive(fun ({ aux = aux } as args) ->

aux.trampolineHolder.Post ctxt (fun () -> args.cont () ))

let switchToNewThread() =

protectedPrimitive(fun ({ aux = aux } as args) ->

aux.trampolineHolder.StartThread (fun () -> args.cont () ) )

let switchToThreadPool() =

protectedPrimitive(fun ({ aux = aux } as args) ->

aux.trampolineHolder.QueueWorkItem (fun () -> args.cont ()) )

//----------------------------------

// DERIVED ASYNC RESYNC HELPERS

let delimitContinuationsWith (delimiter : TrampolineHolder -> (unit -> FakeUnitValue) -> FakeUnitValue) ({ aux = aux } as args) =

let trampolineHolder = aux.trampolineHolder

{ args with

cont = (fun x -> delimiter trampolineHolder (fun () -> args.cont x))

aux = { aux with

econt = (fun x -> delimiter trampolineHolder (fun () -> aux.econt x ));

ccont = (fun x -> delimiter trampolineHolder (fun () -> aux.ccont x))

}

}

#if FX_NO_SYNC_CONTEXT

let getSyncContext _ = null

let delimitSyncContext args = args

let postOrQueue _ (trampolineHolder:TrampolineHolder) f =

trampolineHolder.QueueWorkItem f

let getSyncContext () = System.Threading.SynchronizationContext.Current

let postOrQueue (ctxt : SynchronizationContext) (trampolineHolder:TrampolineHolder) f =

match ctxt with

| null -> trampolineHolder.QueueWorkItem f

| _ -> trampolineHolder.Post ctxt f

let delimitSyncContext args =

match getSyncContext () with

| null -> args

| ctxt ->

let aux = args.aux

let trampolineHolder = aux.trampolineHolder

{ args with

cont = (fun x -> trampolineHolder.Post ctxt (fun () -> args.cont x))