This repository has been archived by the owner on Jan 3, 2023. It is now read-only.
/
control.fs
executable file
·2881 lines (2453 loc) · 133 KB
/
control.fs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information.
#if FX_NO_CANCELLATIONTOKEN_CLASSES
namespace System
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>)
namespace System.Threading
#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 -> ctr.source = null
| _ -> 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 -> ct.source = null
| _ -> 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)
#endif
namespace Microsoft.FSharp.Control
#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.Threading
open System.IO
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
type BindingFlags = ReflectionAdapters.BindingFlags
#else
type BindingFlags = System.Reflection.BindingFlags
#endif
#if FX_NO_TASK
#else
open System.Threading
open System.Threading.Tasks
#endif
#if FX_NO_OPERATION_CANCELLED
type OperationCanceledException(s : System.String) =
inherit System.Exception(s)
new () = new OperationCanceledException("The operation has been canceled")
#endif
#if FX_NO_EXCEPTIONDISPATCHINFO
[<AllowNullLiteral>]
type ExceptionDispatchInfo(exn: System.Exception) =
static member Capture(exn) = ExceptionDispatchInfo(exn)
member __.Throw() = raise exn; ()
member __.SourceException = exn
#else
open System.Runtime.ExceptionServices
#endif
/// 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
#else
[<ThreadStatic>]
[<DefaultValue>]
static val mutable private thisThreadHasTrampoline : bool
#endif
static member ThisThreadHasTrampoline =
#if FX_NO_THREAD_STATIC
true
#else
Trampoline.thisThreadHasTrampoline
#endif
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
#else
let thisIsTopTrampoline =
if Trampoline.thisThreadHasTrampoline then
false
else
Trampoline.thisThreadHasTrampoline <- true
true
#endif
try
loop firstAction
finally
#if FX_NO_THREAD_STATIC
()
#else
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 FSHARP_CORE_NETCORE_PORTABLE
// 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
#endif
type TrampolineHolder() as this =
let mutable trampoline = null
static let unfake FakeUnit = ()
// preallocate context-switching callbacks
#if FX_NO_SYNC_CONTEXT
#else
// 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
)
#endif
// 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
#else
// 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
)
#endif
#if FX_NO_SYNC_CONTEXT
#else
member this.Post (ctxt: SynchronizationContext) (f : unit -> FakeUnitValue) =
ctxt.Post (sendOrPostCallback, state=(f |> box))
FakeUnit
#endif
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)
#else
(new Thread((fun _ -> this.Protect f |> unfake), IsBackground=true)).Start()
FakeUnit
#endif
#else
// 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
#endif
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 Result<'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
#else
/// Global mutable state used to associate Exception
let associationTable = System.Runtime.CompilerServices.ConditionalWeakTable<exn, ExceptionDispatchInfo>()
#endif
type ExceptionDispatchInfo with
member edi.GetAssociatedSourceException() =
let exn = edi.SourceException
#if FX_NO_CONDITIONAL_WEAK_TABLE
#else
// 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 _ -> ()
#endif
exn
// Capture, but prefer the saved information if available
static member inline RestoreOrCapture(exn) =
#if FX_NO_CONDITIONAL_WEAK_TABLE
#else
match lock associationTable (fun () -> associationTable.TryGetValue(exn)) with
| true, edi -> edi
| _ ->
#endif
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
#else
// 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
#endif
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
| Result.Ok r -> args.cont r
| Result.Error e -> args.aux.econt e
| Result.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> =
tryFinallyA (fun () -> Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose r) (callA f r)
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
#else
let switchTo (ctxt: SynchronizationContext) =
protectedPrimitive(fun ({ aux = aux } as args) ->
aux.trampolineHolder.Post ctxt (fun () -> args.cont () ))
#endif
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
#else
let getSyncContext () = System.Threading.SynchronizationContext.Current
let postOrQueue (ctxt : SynchronizationContext) (trampolineHolder:TrampolineHolder) f =
match ctxt with
| null -> trampolineHolder.QueueWorkItem f
| _ -> trampolineHolder.Post ctxt f