@@ -65,24 +65,19 @@ open System.Runtime.ExceptionServices
65
65
open System.Diagnostics
66
66
67
67
type ITrampolineInvocation =
68
- abstract member MoveNext: unit -> unit
68
+ abstract member MoveNext: unit -> bool
69
69
abstract IsCompleted: bool
70
- abstract ReplayExceptionIfStored: unit -> unit
71
70
72
- [<Struct ; NoComparison ; NoEquality>]
73
- type CancellableStateMachineData < 'T > =
74
-
75
- [<DefaultValue ( false ) >]
76
- val mutable Result : 'T
71
+ type internal CancellableStateMachine < 'TOverall > = ResumableStateMachine < 'TOverall >
72
+ type internal ICancellableStateMachine < 'TOverall > = IResumableStateMachine < 'TOverall >
73
+ type internal CancellableResumptionFunc < 'TOverall > = ResumptionFunc < 'TOverall >
74
+ type internal CancellableResumptionDynamicInfo < 'TOverall > = ResumptionDynamicInfo < 'TOverall >
75
+ type internal CancellableCode < 'TOverall , 'T > = ResumableCode < 'TOverall , 'T >
77
76
78
- [<DefaultValue( false ) >]
79
- val mutable NextInvocation : ITrampolineInvocation voption
80
-
81
- and CancellableStateMachine < 'TOverall > = ResumableStateMachine< CancellableStateMachineData< 'TOverall>>
82
- and ICancellableStateMachine < 'TOverall > = IResumableStateMachine< CancellableStateMachineData< 'TOverall>>
83
- and CancellableResumptionFunc < 'TOverall > = ResumptionFunc< CancellableStateMachineData< 'TOverall>>
84
- and CancellableResumptionDynamicInfo < 'TOverall > = ResumptionDynamicInfo< CancellableStateMachineData< 'TOverall>>
85
- and CancellableCode < 'TOverall , 'T > = ResumableCode< CancellableStateMachineData< 'TOverall>, 'T>
77
+ [<Struct; NoComparison; NoEquality>]
78
+ type PendingInvocation =
79
+ | Delayed of ITrampolineInvocation
80
+ | Immediate of ITrampolineInvocation
86
81
87
82
[<Sealed>]
88
83
type Trampoline ( cancellationToken : CancellationToken ) =
@@ -92,9 +87,19 @@ type Trampoline(cancellationToken: CancellationToken) =
92
87
[<Literal>]
93
88
static let bindDepthLimit = 100
94
89
95
- static let current = new ThreadLocal < Trampoline>()
90
+ static let current = new AsyncLocal < Trampoline voption >()
96
91
97
- let delayed = System.Collections.Generic.Stack< ITrampolineInvocation>()
92
+ let pending = System.Collections.Generic.Stack<_>()
93
+
94
+ let mutable lastError : ExceptionDispatchInfo voption = ValueNone
95
+ let mutable storedError : ExceptionDispatchInfo voption = ValueNone
96
+
97
+ member _.ReplayException () =
98
+ match storedError with
99
+ | ValueSome edi ->
100
+ storedError <- ValueNone
101
+ edi.Throw()
102
+ | _ -> ()
98
103
99
104
member this.IsCancelled = cancellationToken.IsCancellationRequested
100
105
@@ -103,110 +108,74 @@ type Trampoline(cancellationToken: CancellationToken) =
103
108
104
109
member this.ShoudBounce = bindDepth % bindDepthLimit = 0
105
110
106
- static member Install ct = current.Value <- Trampoline ct
111
+ member this.SetDelayed ( invocation ) = pending.Push ( Delayed invocation )
107
112
108
- member val LastError : ExceptionDispatchInfo voption = ValueNone with get, set
113
+ member this.RunImmediate ( invocation : ITrampolineInvocation ) =
114
+ let captureException exn =
115
+ match lastError with
116
+ | ValueSome edi when edi.SourceException = exn -> ()
117
+ | _ -> lastError <- ValueSome <| ExceptionDispatchInfo.Capture exn
109
118
110
- member this.RunDelayed ( continuation , invocation ) =
111
- // The calling state machine is now suspended. We need to resume it next.
112
- delayed.Push continuation
113
- // Schedule the delayed invocation to run.
114
- delayed.Push invocation
119
+ storedError <- lastError
115
120
116
- member this.RunImmediate ( invocation : ITrampolineInvocation ) =
117
121
bindDepth <- bindDepth + 1
118
122
119
- try
120
- // This can throw, which is fine. We want the exception to propagate to the calling machine.
121
- invocation.MoveNext()
123
+ pending.Push( Immediate invocation)
122
124
125
+ try
123
126
while not invocation.IsCompleted do
124
- if delayed.Peek() .IsCompleted then
125
- delayed.Pop() |> ignore
126
- else
127
- delayed.Peek() .MoveNext()
128
- // In case this was a delayed invocation, which captures the exception, we need to replay it.
129
- invocation.ReplayExceptionIfStored()
127
+ match pending.Peek() with
128
+ | Immediate i ->
129
+ if i.MoveNext() then
130
+ pending.Pop() |> ignore
131
+ | Delayed d ->
132
+ try
133
+ if d.MoveNext() then
134
+ pending.Pop() |> ignore
135
+ with exn ->
136
+ pending.Pop() |> ignore
137
+ captureException exn
138
+
139
+ this.ReplayException()
130
140
finally
131
141
bindDepth <- bindDepth - 1
132
142
133
- static member Current = current.Value
143
+ static member Current = current.Value.Value
144
+
145
+ static member Install ct =
146
+ current.Value <- ValueSome <| Trampoline ct
134
147
135
148
type ITrampolineInvocation < 'T > =
136
149
inherit ITrampolineInvocation
137
150
abstract Result: 'T
138
151
139
- [<AutoOpen>]
140
- module ExceptionDispatchInfoHelpers =
141
- type ExceptionDispatchInfo with
142
- member edi.ThrowAny () =
143
- edi.Throw()
144
- Unchecked.defaultof<_>
145
-
146
- static member RestoreOrCapture ( exn : exn ) =
147
- match Trampoline.Current.LastError with
148
- | ValueSome edi when edi.SourceException = exn -> edi
149
- | _ ->
150
- let edi = ExceptionDispatchInfo.Capture exn
151
- Trampoline.Current.LastError <- ValueSome edi
152
- edi
153
-
154
152
[<NoEquality; NoComparison>]
155
153
type ICancellableInvokable < 'T > =
156
- abstract Create: bool -> ITrampolineInvocation < 'T >
154
+ abstract Create: unit -> ITrampolineInvocation < 'T >
157
155
158
156
[<NoEquality; NoComparison>]
159
- type CancellableInvocation < 'T , 'Machine when 'Machine :> IAsyncStateMachine and 'Machine :> ICancellableStateMachine < 'T >>
160
- ( machine : 'Machine, delayed : bool ) =
157
+ type CancellableInvocation < 'T , 'Machine
158
+ when 'Machine: struct and 'Machine :> IAsyncStateMachine and 'Machine :> ICancellableStateMachine < 'T >>( machine : 'Machine ) =
161
159
let mutable machine = machine
162
- let mutable storedException = ValueNone
163
- let mutable finished = false
164
-
165
- new ( machine) = CancellableInvocation( machine, false )
166
160
167
161
interface ITrampolineInvocation< 'T> with
168
- member this.MoveNext () =
169
- let pushDelayed () =
170
- match machine.Data.NextInvocation with
171
- | ValueSome delayed -> Trampoline.Current.RunDelayed( this, delayed)
172
- | _ -> finished <- true
173
-
174
- if delayed then
175
- // If the invocation is delayed, we need to store the exception.
176
- try
177
- machine.MoveNext()
178
- pushDelayed ()
179
- with exn ->
180
- finished <- true
181
- storedException <- ValueSome <| ExceptionDispatchInfo.RestoreOrCapture exn
182
- else
183
- machine.MoveNext()
184
- pushDelayed ()
185
-
186
- member _.Result = machine.Data.Result
187
- member _.IsCompleted = finished
188
-
189
- member _.ReplayExceptionIfStored () =
190
- storedException |> ValueOption.iter _. Throw()
162
+ member _.MoveNext () =
163
+ machine.MoveNext()
164
+ machine.ResumptionPoint = - 1
191
165
192
- interface ICancellableInvokable< 'T> with
193
- member _.Create ( delayed ) =
194
- CancellableInvocation<_, _>( machine, delayed)
166
+ member _.Result = machine.Data
167
+ member _.IsCompleted = machine.ResumptionPoint = - 1
195
168
196
169
[<Struct; NoComparison>]
197
- type Cancellable < 'T >( invokable : ICancellableInvokable <'T >) =
170
+ type Cancellable < 'T >( clone : unit -> ITrampolineInvocation < 'T >) =
198
171
199
- member _.GetInvocation ( delayed ) = invokable.Create ( delayed )
172
+ member _.GetInvocation () = clone ( )
200
173
201
174
[<AutoOpen>]
202
175
module CancellableCode =
203
176
204
177
let inline filterCancellation ( catch : exn -> CancellableCode < _ , _ >) exn =
205
- CancellableCode( fun sm ->
206
- try
207
- ( catch exn) .Invoke(& sm)
208
- with :? OperationCanceledException when Trampoline.Current.IsCancelled ->
209
- true )
178
+ CancellableCode( fun sm -> Trampoline.Current.IsCancelled || ( catch exn) .Invoke(& sm))
210
179
211
180
let inline throwIfCancellationRequested ( code : CancellableCode < _ , _ >) =
212
181
CancellableCode( fun sm ->
@@ -223,7 +192,7 @@ type CancellableBuilder() =
223
192
224
193
member inline _.Return ( value : 'T ) : CancellableCode < 'T , 'T > =
225
194
CancellableCode< 'T, _>( fun sm ->
226
- sm.Data.Result <- value
195
+ sm.Data <- value
227
196
true )
228
197
229
198
member inline _.Combine
@@ -266,39 +235,35 @@ type CancellableBuilder() =
266
235
: CancellableCode < 'Data , 'T > =
267
236
CancellableCode( fun sm ->
268
237
if __ useResumableCode then
269
- let mutable invocation = code.GetInvocation Trampoline.Current.ShoudBounce
238
+ let mutable invocation = code.GetInvocation()
270
239
271
240
if Trampoline.Current.ShoudBounce then
272
241
// Suspend this state machine and schedule both parts to run on the trampoline.
273
242
match __ resumableEntry () with
274
243
// Suspending
275
244
| Some contID ->
276
245
sm.ResumptionPoint <- contID
277
- sm.Data.NextInvocation <- ValueSome invocation
246
+ Trampoline.Current.SetDelayed invocation
278
247
false
279
248
// Resuming
280
249
| None ->
281
- sm.Data.NextInvocation <- ValueNone
282
- // At this point we either have a result or an exception.
283
- invocation.ReplayExceptionIfStored()
250
+ Trampoline.Current.ReplayException()
284
251
( continuation invocation.Result) .Invoke(& sm)
285
252
else
286
253
Trampoline.Current.RunImmediate invocation
287
254
( continuation invocation.Result) .Invoke(& sm)
288
255
289
256
else
290
257
// Dynamic Bind.
291
-
292
- let mutable invocation = code.GetInvocation Trampoline.Current.ShoudBounce
258
+ let mutable invocation = code.GetInvocation()
293
259
294
260
if Trampoline.Current.ShoudBounce then
295
261
let cont =
296
262
CancellableResumptionFunc< 'Data>( fun sm ->
297
- sm.Data.NextInvocation <- ValueNone
298
- invocation.ReplayExceptionIfStored()
263
+ Trampoline.Current.ReplayException()
299
264
( continuation invocation.Result) .Invoke(& sm))
300
265
301
- sm.Data.NextInvocation <- ValueSome invocation
266
+ Trampoline.Current.SetDelayed invocation
302
267
sm.ResumptionDynamicInfo.ResumptionFunc <- cont
303
268
false
304
269
else
@@ -320,7 +285,9 @@ type CancellableBuilder() =
320
285
321
286
( SetStateMachineMethodImpl<_>( fun _ _ -> ()))
322
287
323
- ( AfterCode<_, _>( fun sm -> Cancellable( CancellableInvocation( sm))))
288
+ ( AfterCode<_, _>( fun sm ->
289
+ let copy = sm
290
+ Cancellable( fun () -> CancellableInvocation( copy))))
324
291
else
325
292
// Dynamic Run.
326
293
@@ -336,8 +303,7 @@ type CancellableBuilder() =
336
303
}
337
304
338
305
let sm = CancellableStateMachine( ResumptionDynamicInfo = resumptionInfo)
339
-
340
- Cancellable( CancellableInvocation( sm))
306
+ Cancellable( fun () -> CancellableInvocation( sm))
341
307
342
308
namespace Internal.Utilities.Library
343
309
@@ -354,22 +320,20 @@ module CancellableAutoOpens =
354
320
module Cancellable =
355
321
open Internal.Utilities .Library .CancellableImplementation
356
322
357
- let run ct ( code : Cancellable < _ >) =
358
- use _ = FSharp.Compiler.Cancellable.UsingToken ct
359
-
360
- let invocation = code.GetInvocation( false )
361
- Trampoline.Install ct
323
+ let run ( code : Cancellable < _ >) =
324
+ let invocation = code.GetInvocation()
325
+ Trampoline.Install FSharp.Compiler.Cancellable.Token
362
326
Trampoline.Current.RunImmediate invocation
363
- invocation
327
+ invocation.Result
364
328
365
329
let runWithoutCancellation code =
366
- code |> run CancellationToken.None |> _. Result
330
+ use _ = FSharp.Compiler.Cancellable.UsingToken CancellationToken.None
331
+ run code
367
332
368
333
let toAsync code =
369
334
async {
370
- let! ct = Async.CancellationToken
371
-
372
- return run ct code |> _. Result
335
+ use! _holder = FSharp.Compiler.Cancellable.UseToken()
336
+ return run code
373
337
}
374
338
375
339
let token () =
0 commit comments