diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index adcd4d80f30..a9d74633843 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -1371,7 +1371,7 @@ module MutRecBindingChecking = let baseTy, tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurrence.Use WarnOnIWSAM.Yes envInstance tpenv synBaseTy let baseTy = baseTy |> convertToTypeWithMetadataIfPossible g TcNewExpr cenv envInstance tpenv baseTy (Some synBaseTy.Range) true arg m - with RecoverableException e -> + with e -> errorRecovery e m mkUnit g m, tpenv let envInstance = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envInstance | None -> envInstance @@ -4869,7 +4869,7 @@ module TcDeclarations = //------------------------------------------------------------------------- // Bind module types //------------------------------------------------------------------------- - +#nowarn FS3511 let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcEnv) synSigDecl: Cancellable = cancellable { let g = cenv.g @@ -5020,7 +5020,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE return env - with RecoverableException exn -> + with exn -> errorRecovery exn endm return env } @@ -5042,8 +5042,14 @@ and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = return! TcSignatureElementsNonMutRec cenv parent typeNames endm env defs } -and TcSignatureElementsNonMutRec cenv parent typeNames endm env defs = - Cancellable.fold (TcSignatureElementNonMutRec cenv parent typeNames endm) env defs +and TcSignatureElementsNonMutRec cenv parent typeNames endm env defs = + cancellable { + match defs with + | [] -> return env + | def :: rest -> + let! env = TcSignatureElementNonMutRec cenv parent typeNames endm env def + return! TcSignatureElementsNonMutRec cenv parent typeNames endm env rest + } and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (defs: SynModuleSigDecl list) = cancellable { @@ -5370,7 +5376,6 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem // Now typecheck. let! moduleContents, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModuleRef moduleEntity)) endm envForModule xml None [] moduleDefs - |> cenv.stackGuard.GuardCancellable // Get the inferred type of the decls and record it in the modul. moduleEntity.entity_modul_type <- MaybeLazy.Strict moduleTyAcc.Value @@ -5462,7 +5467,6 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo [] defs - |> cenv.stackGuard.GuardCancellable MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo let env, openDecls = @@ -5492,20 +5496,17 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem return (defns, [], topAttrs), env, envAtEnd - with RecoverableException exn -> + with exn -> errorRecovery exn synDecl.Range return ([], [], []), env, env } /// The non-mutually recursive case for a sequence of declarations -and [] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) (ct: CancellationToken) = - - if ct.IsCancellationRequested then - ValueOrCancelled.Cancelled(OperationCanceledException ct) - else +and TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) = + cancellable { match moreDefs with | [] -> - ValueOrCancelled.Value (List.rev defsSoFar, envAtEnd) + return List.rev defsSoFar, envAtEnd | firstDef :: otherDefs -> // Lookahead one to find out the scope of the next declaration. let scopem = @@ -5514,14 +5515,9 @@ and [] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm else unionRanges (List.head otherDefs).Range endm - let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef |> cenv.stackGuard.GuardCancellable) - - match result with - | ValueOrCancelled.Cancelled x -> - ValueOrCancelled.Cancelled x - | ValueOrCancelled.Value(firstDef, env, envAtEnd) -> - TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs ct - + let! firstDef, env, envAtEnd = TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef + return! TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ((firstDef :: defsSoFar), env, envAtEnd) otherDefs + } and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 synModuleDecls = cancellable { @@ -5546,21 +5542,15 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 return (moduleContents, topAttrsNew, envAtEnd) | None -> - let! ct = Cancellable.token () - let result = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls ct - - match result with - | ValueOrCancelled.Value(compiledDefs, envAtEnd) -> - // Apply the functions for each declaration to build the overall expression-builder - let moduleDefs = List.collect p13 compiledDefs - let moduleDefs = match openDecls0 with [] -> moduleDefs | _ -> TMDefOpens openDecls0 :: moduleDefs - let moduleContents = TMDefs moduleDefs - - // Collect up the attributes that are global to the file - let topAttrsNew = List.collect p33 compiledDefs - return (moduleContents, topAttrsNew, envAtEnd) - | ValueOrCancelled.Cancelled x -> - return! Cancellable(fun _ -> ValueOrCancelled.Cancelled x) + let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls + // Apply the functions for each declaration to build the overall expression-builder + let moduleDefs = List.collect p13 compiledDefs + let moduleDefs = match openDecls0 with [] -> moduleDefs | _ -> TMDefOpens openDecls0 :: moduleDefs + let moduleContents = TMDefs moduleDefs + + // Collect up the attributes that are global to the file + let topAttrsNew = List.collect p33 compiledDefs + return (moduleContents, topAttrsNew, envAtEnd) } @@ -5797,7 +5787,6 @@ let CheckOneImplFile let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment x ] let! moduleContents, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDoc.Empty None openDecls0 defs - |> cenv.stackGuard.GuardCancellable let implFileTypePriorToSig = moduleTyAcc.Value @@ -5824,7 +5813,7 @@ let CheckOneImplFile for check in cenv.css.GetPostInferenceChecksPreDefaults() do try check() - with RecoverableException exn -> + with exn -> errorRecovery exn m conditionallySuppressErrorReporting (checkForErrors()) (fun () -> diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index eb96a5f6e0b..5a15dad664c 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -882,22 +882,23 @@ type StackGuard(maxDepth: int, name: string) = [] line: int ) = - Activity.addEventWithTags - "DiagnosticsLogger.StackGuard.Guard" - (seq { - Activity.Tags.stackGuardName, box name - Activity.Tags.stackGuardCurrentDepth, depth - Activity.Tags.stackGuardMaxDepth, maxDepth - Activity.Tags.callerMemberName, memberName - Activity.Tags.callerFilePath, path - Activity.Tags.callerLineNumber, line - }) - depth <- depth + 1 try if depth % maxDepth = 0 then + use _ = + Activity.start + "DiagnosticsLogger.StackGuard.Guard" + (seq { + Activity.Tags.stackGuardName, name + Activity.Tags.stackGuardCurrentDepth, string depth + Activity.Tags.stackGuardMaxDepth, string maxDepth + Activity.Tags.callerMemberName, memberName + Activity.Tags.callerFilePath, path + Activity.Tags.callerLineNumber, string line + }) + async { do! Async.SwitchToNewThread() Thread.CurrentThread.Name <- $"F# Extra Compilation Thread for {name} (depth {depth})" @@ -909,10 +910,6 @@ type StackGuard(maxDepth: int, name: string) = finally depth <- depth - 1 - [] - member x.GuardCancellable(original: Cancellable<'T>) = - Cancellable(fun ct -> x.Guard(fun () -> Cancellable.run ct original)) - static member val DefaultDepth = #if DEBUG GetEnvInteger "FSHARP_DefaultStackGuardDepth" 50 diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index 02471dd383b..f545babce8d 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -470,8 +470,6 @@ type StackGuard = [] line: int -> 'T - member GuardCancellable: Internal.Utilities.Library.Cancellable<'T> -> Internal.Utilities.Library.Cancellable<'T> - static member GetDepthOption: string -> int /// This represents the global state established as each task function runs as part of the build. diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index aa23d1534ab..a6a760e0580 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -118,7 +118,7 @@ type DelayedILModuleReader = None | _ -> Some this.result) } - | _ -> cancellable.Return(Some this.result) + | _ -> cancellable { return Some this.result } [] type FSharpReferencedProject = diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index bae9c6f8299..fc5160dd766 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -1,3 +1,4 @@ +#nowarn FS3513 namespace FSharp.Compiler open System @@ -15,18 +16,11 @@ open System.Threading [] type Cancellable = - static let tokenHolder = AsyncLocal() + static let tokenHolder = AsyncLocal() - static let guard = - String.IsNullOrWhiteSpace(Environment.GetEnvironmentVariable("DISABLE_CHECKANDTHROW_ASSERT")) + static member HasCancellationToken = tokenHolder.Value <> CancellationToken.None - static let ensureToken msg = - tokenHolder.Value - |> ValueOption.defaultWith (fun () -> if guard then failwith msg else CancellationToken.None) - - static member HasCancellationToken = tokenHolder.Value.IsSome - - static member Token = ensureToken "Token not available outside of Cancellable computation." + static member Token = tokenHolder.Value static member UseToken() = async { @@ -36,191 +30,300 @@ type Cancellable = static member UsingToken(ct) = let oldCt = tokenHolder.Value - tokenHolder.Value <- ValueSome ct + tokenHolder.Value <- ct { new IDisposable with member _.Dispose() = tokenHolder.Value <- oldCt } static member CheckAndThrow() = - let token = ensureToken "CheckAndThrow invoked outside of Cancellable computation." - token.ThrowIfCancellationRequested() + tokenHolder.Value.ThrowIfCancellationRequested() static member TryCheckAndThrow() = - match tokenHolder.Value with - | ValueNone -> () - | ValueSome token -> token.ThrowIfCancellationRequested() + tokenHolder.Value.ThrowIfCancellationRequested() -namespace Internal.Utilities.Library +namespace Internal.Utilities.Library.CancellableImplementation + +type Cancellable = FSharp.Compiler.Cancellable open System open System.Threading -open FSharp.Compiler open FSharp.Core.CompilerServices.StateMachineHelpers -[] -type ValueOrCancelled<'TResult> = - | Value of result: 'TResult - | Cancelled of ``exception``: OperationCanceledException +open Microsoft.FSharp.Core.CompilerServices +open System.Runtime.CompilerServices +open System.Runtime.ExceptionServices -[] -type Cancellable<'T> = Cancellable of (CancellationToken -> ValueOrCancelled<'T>) +type ITrampolineInvocation = + abstract member MoveNext: unit -> bool + abstract IsCompleted: bool -module Cancellable = +type internal CancellableStateMachine<'TOverall> = ResumableStateMachine<'TOverall> +type internal ICancellableStateMachine<'TOverall> = IResumableStateMachine<'TOverall> +type internal CancellableResumptionFunc<'TOverall> = ResumptionFunc<'TOverall> +type internal CancellableResumptionDynamicInfo<'TOverall> = ResumptionDynamicInfo<'TOverall> +type internal CancellableCode<'TOverall, 'T> = ResumableCode<'TOverall, 'T> - let inline run (ct: CancellationToken) (Cancellable oper) = - if ct.IsCancellationRequested then - ValueOrCancelled.Cancelled(OperationCanceledException ct) - else - try - oper ct - with - | :? OperationCanceledException as e when ct.IsCancellationRequested -> ValueOrCancelled.Cancelled e - | :? OperationCanceledException as e -> InvalidOperationException("Wrong cancellation token", e) |> raise +[] +type PendingInvocation = + | Delayed of ITrampolineInvocation + | Immediate of ITrampolineInvocation - let fold f acc seq = - Cancellable(fun ct -> - let mutable acc = ValueOrCancelled.Value acc +[] +type Trampoline() = - for x in seq do - match acc with - | ValueOrCancelled.Value accv -> acc <- run ct (f accv x) - | ValueOrCancelled.Cancelled _ -> () + let mutable bindDepth = 0 - acc) + [] + static let bindDepthLimit = 100 - let runWithoutCancellation comp = - use _ = Cancellable.UsingToken CancellationToken.None - let res = run CancellationToken.None comp + static let current = new AsyncLocal() - match res with - | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" - | ValueOrCancelled.Value r -> r + let pending = System.Collections.Generic.Stack<_>() - let toAsync c = - async { - use! _holder = Cancellable.UseToken() - - let! ct = Async.CancellationToken - - return! - Async.FromContinuations(fun (cont, _econt, ccont) -> - match run ct c with - | ValueOrCancelled.Value v -> cont v - | ValueOrCancelled.Cancelled ce -> ccont ce) - } + let mutable lastError: ExceptionDispatchInfo voption = ValueNone + let mutable storedError: ExceptionDispatchInfo voption = ValueNone - let token () = Cancellable(ValueOrCancelled.Value) + member _.ReplayException() = + match storedError with + | ValueSome edi -> + storedError <- ValueNone + edi.Throw() + | _ -> () -type CancellableBuilder() = + member this.ShoudBounce = bindDepth % bindDepthLimit = 0 - member inline _.Delay([] f) = - Cancellable(fun ct -> - let (Cancellable g) = f () - g ct) + member this.SetDelayed(invocation) = pending.Push(Delayed invocation) - member inline _.Bind(comp, [] k) = - Cancellable(fun ct -> + member this.RunImmediate(invocation: ITrampolineInvocation) = + let captureException exn = + match lastError with + | ValueSome edi when edi.SourceException = exn -> () + | _ -> lastError <- ValueSome <| ExceptionDispatchInfo.Capture exn - __debugPoint "" + storedError <- lastError - match Cancellable.run ct comp with - | ValueOrCancelled.Value v1 -> Cancellable.run ct (k v1) - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) + bindDepth <- bindDepth + 1 - member inline _.BindReturn(comp, [] k) = - Cancellable(fun ct -> + pending.Push(Immediate invocation) - __debugPoint "" + try + while not invocation.IsCompleted do + match pending.Peek() with + | Immediate i -> + if i.MoveNext() then + pending.Pop() |> ignore + | Delayed d -> + try + if d.MoveNext() then + pending.Pop() |> ignore + with exn -> + pending.Pop() |> ignore + captureException exn - match Cancellable.run ct comp with - | ValueOrCancelled.Value v1 -> ValueOrCancelled.Value(k v1) - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) + this.ReplayException() + finally + bindDepth <- bindDepth - 1 - member inline _.Combine(comp1, comp2) = - Cancellable(fun ct -> + static member Current = current.Value.Value - __debugPoint "" + static member Install() = + current.Value <- ValueSome <| Trampoline() - match Cancellable.run ct comp1 with - | ValueOrCancelled.Value() -> Cancellable.run ct comp2 - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) +type ITrampolineInvocation<'T> = + inherit ITrampolineInvocation + abstract Result: 'T - member inline _.TryWith(comp, [] handler) = - Cancellable(fun ct -> +[] +type ICancellableInvokable<'T> = + abstract Create: unit -> ITrampolineInvocation<'T> - __debugPoint "" +[] +type CancellableInvocation<'T, 'Machine + when 'Machine: struct and 'Machine :> IAsyncStateMachine and 'Machine :> ICancellableStateMachine<'T>>(machine: 'Machine) = + let mutable machine = machine - let compRes = - try - match Cancellable.run ct comp with - | ValueOrCancelled.Value res -> ValueOrCancelled.Value(Choice1Of2 res) - | ValueOrCancelled.Cancelled exn -> ValueOrCancelled.Cancelled exn - with err -> - ValueOrCancelled.Value(Choice2Of2 err) + interface ITrampolineInvocation<'T> with + member _.MoveNext() = + machine.MoveNext() + machine.ResumptionPoint = -1 - match compRes with - | ValueOrCancelled.Value res -> - match res with - | Choice1Of2 r -> ValueOrCancelled.Value r - | Choice2Of2 err -> Cancellable.run ct (handler err) - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) + member _.Result = machine.Data + member _.IsCompleted = machine.ResumptionPoint = -1 - member inline _.Using(resource: _ MaybeNull, [] comp) = - Cancellable(fun ct -> +[] +type Cancellable<'T>(clone: unit -> ITrampolineInvocation<'T>) = - __debugPoint "" + member _.GetInvocation() = clone () - let body = comp resource +[] +module CancellableCode = - let compRes = - try - match Cancellable.run ct body with - | ValueOrCancelled.Value res -> ValueOrCancelled.Value(Choice1Of2 res) - | ValueOrCancelled.Cancelled exn -> ValueOrCancelled.Cancelled exn - with err -> - ValueOrCancelled.Value(Choice2Of2 err) + let inline filterCancellation (catch: exn -> CancellableCode<_, _>) (exn: exn) = + CancellableCode(fun sm -> + match exn with + | :? OperationCanceledException as oce when oce.CancellationToken = Cancellable.Token -> raise exn + | _ -> (catch exn).Invoke(&sm)) - match compRes with - | ValueOrCancelled.Value res -> - Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource + let inline throwIfCancellationRequested (code: CancellableCode<_, _>) = + CancellableCode(fun sm -> + Cancellable.Token.ThrowIfCancellationRequested() + code.Invoke(&sm)) - match res with - | Choice1Of2 r -> ValueOrCancelled.Value r - | Choice2Of2 err -> raise err - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) +type CancellableBuilder() = - member inline _.TryFinally(comp, [] compensation) = - Cancellable(fun ct -> + member inline _.Delay(generator: unit -> CancellableCode<'TOverall, 'T>) : CancellableCode<'TOverall, 'T> = + ResumableCode.Delay(fun () -> generator () |> throwIfCancellationRequested) + + [] + member inline _.Zero() : CancellableCode<'TOverall, unit> = ResumableCode.Zero() + + member inline _.Return(value: 'T) : CancellableCode<'T, 'T> = + CancellableCode<'T, _>(fun sm -> + sm.Data <- value + true) + |> throwIfCancellationRequested + + member inline _.Combine + (code1: CancellableCode<'TOverall, unit>, code2: CancellableCode<'TOverall, 'T>) + : CancellableCode<'TOverall, 'T> = + ResumableCode.Combine(code1, code2) + + member inline _.While + ([] condition: unit -> bool, body: CancellableCode<'TOverall, unit>) + : CancellableCode<'TOverall, unit> = + ResumableCode.While(condition, throwIfCancellationRequested body) + + member inline _.TryWith + (body: CancellableCode<'TOverall, 'T>, catch: exn -> CancellableCode<'TOverall, 'T>) + : CancellableCode<'TOverall, 'T> = + ResumableCode.TryWith(body, filterCancellation catch) + + member inline _.TryFinally + (body: CancellableCode<'TOverall, 'T>, [] compensation: unit -> unit) + : CancellableCode<'TOverall, 'T> = + ResumableCode.TryFinally( + body, + ResumableCode<_, _>(fun _sm -> + compensation () + true) + ) + + member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable | null> + (resource: 'Resource, body: 'Resource -> CancellableCode<'TOverall, 'T>) + : CancellableCode<'TOverall, 'T> = + ResumableCode.Using(resource, body) + + member inline _.For(sequence: seq<'T>, body: 'T -> CancellableCode<'TOverall, unit>) : CancellableCode<'TOverall, unit> = + ResumableCode.For(sequence, fun x -> body x |> throwIfCancellationRequested) + + member inline this.Yield(value) = this.Return(value) + + member inline _.Bind + (code: Cancellable<'U>, [] continuation: 'U -> CancellableCode<'Data, 'T>) + : CancellableCode<'Data, 'T> = + CancellableCode(fun sm -> + if __useResumableCode then + let mutable invocation = code.GetInvocation() + + if Trampoline.Current.ShoudBounce then + // Suspend this state machine and schedule both parts to run on the trampoline. + match __resumableEntry () with + // Suspending + | Some contID -> + sm.ResumptionPoint <- contID + Trampoline.Current.SetDelayed invocation + false + // Resuming + | None -> + Trampoline.Current.ReplayException() + (continuation invocation.Result).Invoke(&sm) + else + Trampoline.Current.RunImmediate invocation + (continuation invocation.Result).Invoke(&sm) + + else + // Dynamic Bind. + let mutable invocation = code.GetInvocation() + + if Trampoline.Current.ShoudBounce then + let cont = + CancellableResumptionFunc<'Data>(fun sm -> + Trampoline.Current.ReplayException() + (continuation invocation.Result).Invoke(&sm)) + + Trampoline.Current.SetDelayed invocation + sm.ResumptionDynamicInfo.ResumptionFunc <- cont + false + else + Trampoline.Current.RunImmediate invocation + (continuation invocation.Result).Invoke(&sm)) + + member inline this.ReturnFrom(comp: Cancellable<'T>) : CancellableCode<'T, 'T> = this.Bind(comp, this.Return) + + member inline _.Run(code: CancellableCode<'T, 'T>) : Cancellable<'T> = + if __useResumableCode then + __stateMachine<_, _> + + (MoveNextMethodImpl<_>(fun sm -> + __resumeAt sm.ResumptionPoint + let __stack_code_fin = code.Invoke(&sm) + + if __stack_code_fin then + sm.ResumptionPoint <- -1)) + + (SetStateMachineMethodImpl<_>(fun _ _ -> ())) + + (AfterCode<_, _>(fun sm -> + let copy = sm + Cancellable(fun () -> CancellableInvocation(copy)))) + else + // Dynamic Run. - __debugPoint "" + let initialResumptionFunc = CancellableResumptionFunc(fun sm -> code.Invoke(&sm)) - let compRes = - try - match Cancellable.run ct comp with - | ValueOrCancelled.Value res -> ValueOrCancelled.Value(Choice1Of2 res) - | ValueOrCancelled.Cancelled exn -> ValueOrCancelled.Cancelled exn - with err -> - ValueOrCancelled.Value(Choice2Of2 err) + let resumptionInfo = + { new CancellableResumptionDynamicInfo<_>(initialResumptionFunc) with + member info.MoveNext(sm) = + if info.ResumptionFunc.Invoke(&sm) then + sm.ResumptionPoint <- -1 - match compRes with - | ValueOrCancelled.Value res -> - compensation () + member _.SetStateMachine(_, _) = () + } - match res with - | Choice1Of2 r -> ValueOrCancelled.Value r - | Choice2Of2 err -> raise err - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) + let sm = CancellableStateMachine(ResumptionDynamicInfo = resumptionInfo) + Cancellable(fun () -> CancellableInvocation(sm)) - member inline _.Return v = - Cancellable(fun _ -> ValueOrCancelled.Value v) +namespace Internal.Utilities.Library - member inline _.ReturnFrom(v: Cancellable<'T>) = v +open System.Threading - member inline _.Zero() = - Cancellable(fun _ -> ValueOrCancelled.Value()) +type Cancellable<'T> = CancellableImplementation.Cancellable<'T> [] module CancellableAutoOpens = - let cancellable = CancellableBuilder() + + let cancellable = CancellableImplementation.CancellableBuilder() + +module Cancellable = + open Internal.Utilities.Library.CancellableImplementation + + let run (code: Cancellable<_>) = + let invocation = code.GetInvocation() + Trampoline.Install() + Trampoline.Current.RunImmediate invocation + invocation.Result + + let runWithoutCancellation code = + use _ = Cancellable.UsingToken CancellationToken.None + run code + + let toAsync code = + async { + use! _holder = Cancellable.UseToken() + return run code + } + + let token () = + cancellable { Cancellable.Token } diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 0d82faa68cb..5b41046d6e3 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -6,74 +6,97 @@ open System.Threading [] type Cancellable = static member internal UseToken: unit -> Async - + static member internal UsingToken: CancellationToken -> IDisposable static member HasCancellationToken: bool static member Token: CancellationToken - static member CheckAndThrow: unit -> unit static member TryCheckAndThrow: unit -> unit -namespace Internal.Utilities.Library +namespace Internal.Utilities.Library.CancellableImplementation open System -open System.Threading - -[] -type internal ValueOrCancelled<'TResult> = - | Value of result: 'TResult - | Cancelled of ``exception``: OperationCanceledException - -/// Represents a synchronous, cold-start, cancellable computation with explicit representation of a cancelled result. -/// -/// A cancellable computation may be cancelled via a CancellationToken, which is propagated implicitly. -/// If cancellation occurs, it is propagated as data rather than by raising an OperationCanceledException. -[] -type internal Cancellable<'T> = Cancellable of (CancellationToken -> ValueOrCancelled<'T>) +open Microsoft.FSharp.Core.CompilerServices +open System.Runtime.CompilerServices -module internal Cancellable = - - /// Run a cancellable computation using the given cancellation token - val inline run: ct: CancellationToken -> Cancellable<'T> -> ValueOrCancelled<'T> - - val fold: f: ('State -> 'T -> Cancellable<'State>) -> acc: 'State -> seq: seq<'T> -> Cancellable<'State> +type internal ITrampolineInvocation = + abstract MoveNext: unit -> bool + abstract IsCompleted: bool - /// Run the computation in a mode where it may not be cancelled. The computation never results in a - /// ValueOrCancelled.Cancelled. - val runWithoutCancellation: comp: Cancellable<'T> -> 'T +type internal CancellableStateMachine<'TOverall> = ResumableStateMachine<'TOverall> +type internal ICancellableStateMachine<'TOverall> = IResumableStateMachine<'TOverall> +type internal CancellableResumptionFunc<'TOverall> = ResumptionFunc<'TOverall> +type internal CancellableResumptionDynamicInfo<'TOverall> = ResumptionDynamicInfo<'TOverall> +type internal CancellableCode<'TOverall, 'T> = ResumableCode<'TOverall, 'T> - /// Bind the cancellation token associated with the computation - val token: unit -> Cancellable +type internal ITrampolineInvocation<'T> = + inherit ITrampolineInvocation + abstract Result: 'T - val toAsync: Cancellable<'T> -> Async<'T> +[] +type internal Trampoline = + member SetDelayed: ITrampolineInvocation -> unit + member RunImmediate: ITrampolineInvocation -> unit + member ReplayException: unit -> unit + static member Current: Trampoline + member ShoudBounce: bool + +[] +type internal CancellableInvocation<'T, 'Machine + when 'Machine: struct and 'Machine :> IAsyncStateMachine and 'Machine :> ICancellableStateMachine<'T>> = + interface ITrampolineInvocation<'T> + new: machine: 'Machine -> CancellableInvocation<'T, 'Machine> + +[] +type internal Cancellable<'T> = + new: clone: (unit -> ITrampolineInvocation<'T>) -> Cancellable<'T> + member GetInvocation: unit -> ITrampolineInvocation<'T> type internal CancellableBuilder = - new: unit -> CancellableBuilder - member inline BindReturn: comp: Cancellable<'T> * [] k: ('T -> 'U) -> Cancellable<'U> + member inline Bind: + code: Cancellable<'U> * [] continuation: ('U -> CancellableCode<'Data, 'T>) -> + CancellableCode<'Data, 'T> - member inline Bind: comp: Cancellable<'T> * [] k: ('T -> Cancellable<'U>) -> Cancellable<'U> + member inline Combine: + code1: CancellableCode<'Data, unit> * code2: CancellableCode<'Data, 'T> -> CancellableCode<'Data, 'T> - member inline Combine: comp1: Cancellable * comp2: Cancellable<'T> -> Cancellable<'T> + member inline Delay: generator: (unit -> CancellableCode<'Data, 'T>) -> CancellableCode<'Data, 'T> + member inline For: sequence: 'e seq * body: ('e -> CancellableCode<'Data, unit>) -> CancellableCode<'Data, unit> + member inline Return: value: 'T -> CancellableCode<'T, 'T> + member inline ReturnFrom: comp: Cancellable<'T> -> CancellableCode<'T, 'T> + member inline Run: code: CancellableCode<'T, 'T> -> Cancellable<'T> - member inline Delay: [] f: (unit -> Cancellable<'T>) -> Cancellable<'T> + member inline TryFinally: + body: CancellableCode<'Data, 'T> * compensation: (unit -> unit) -> CancellableCode<'Data, 'T> - member inline Return: v: 'T -> Cancellable<'T> + member inline TryWith: + body: CancellableCode<'Data, 'T> * catch: (exn -> CancellableCode<'Data, 'T>) -> CancellableCode<'Data, 'T> - member inline ReturnFrom: v: Cancellable<'T> -> Cancellable<'T> + member inline While: condition: (unit -> bool) * body: CancellableCode<'Data, unit> -> CancellableCode<'Data, unit> + member inline Yield: value: 'a -> CancellableCode<'a, 'a> + member inline Zero: unit -> CancellableCode<'Data, unit> - member inline TryFinally: comp: Cancellable<'T> * [] compensation: (unit -> unit) -> Cancellable<'T> + member inline Using: + resource: 'Resource * body: ('Resource -> CancellableCode<'TOverall, 'T>) -> CancellableCode<'TOverall, 'T> + when 'Resource :> IDisposable | null - member inline TryWith: - comp: Cancellable<'T> * [] handler: (exn -> Cancellable<'T>) -> Cancellable<'T> +[] +module internal CancellableCode = + val inline throwIfCancellationRequested: CancellableCode<'a, 'b> -> CancellableCode<'a, 'c> - member inline Using: - resource: 'Resource MaybeNull * [] comp: ('Resource MaybeNull -> Cancellable<'T>) -> - Cancellable<'T> - when 'Resource :> IDisposable and 'Resource: not struct and 'Resource: not null +namespace Internal.Utilities.Library - member inline Zero: unit -> Cancellable +open System.Threading +open Internal.Utilities.Library.CancellableImplementation + +type internal Cancellable<'T> = CancellableImplementation.Cancellable<'T> [] module internal CancellableAutoOpens = - val cancellable: CancellableBuilder + val cancellable: CancellableImplementation.CancellableBuilder + +module internal Cancellable = + val runWithoutCancellation: code: Cancellable<'a> -> 'a + val toAsync: code: Cancellable<'a> -> Async<'a> + val token: unit -> Cancellable diff --git a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs index f307586cd5c..dffede3efba 100644 --- a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs @@ -173,11 +173,6 @@ open Ns1.Ns2 let t: T = T() """ - -[] -let ``CheckAndThrow is not allowed to throw outside of cancellable`` () = - Assert.Throws(fun () -> Cancellable.CheckAndThrow()) - [] let ``Type defs 01 - assembly import`` () = let source = source1