diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 07b40b6b11..e6525223fc 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -4870,9 +4870,9 @@ module TcDeclarations = //------------------------------------------------------------------------- // Bind module types //------------------------------------------------------------------------- - -let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcEnv) synSigDecl: Cancellable = - cancellable { +#nowarn 3511 +let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcEnv) synSigDecl: Async2 = + async2 { let g = cenv.g try match synSigDecl with @@ -5021,14 +5021,14 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE return env - with RecoverableException exn -> + with exn -> errorRecovery exn endm return env } and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = - cancellable { + async2 { // Ensure the .Deref call in UpdateAccModuleOrNamespaceType succeeds if cenv.compilingCanonicalFslibModuleType then let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs @@ -5044,10 +5044,16 @@ and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = } and TcSignatureElementsNonMutRec cenv parent typeNames endm env defs = - Cancellable.fold (TcSignatureElementNonMutRec cenv parent typeNames endm) env defs + async2 { + 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 { + async2 { let m = match defs with [] -> m | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges let scopem = (defs, m) ||> List.foldBack (fun h m -> unionRanges h.Range m) @@ -5102,7 +5108,7 @@ and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (d and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id, moduleKind, defs, m: range, xml) = - cancellable { + async2 { let endm = m.EndRange // use end of range for errors // Create the module type that will hold the results of type checking.... @@ -5260,7 +5266,7 @@ let TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial /// The non-mutually recursive case for a declaration let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem env synDecl = - cancellable { + async2 { let g = cenv.g cenv.synArgNameGenerator.Reset() let tpenv = emptyUnscopedTyparEnv @@ -5371,7 +5377,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 @@ -5463,7 +5468,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 = @@ -5493,20 +5497,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) = + async2 { 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 = @@ -5515,17 +5516,12 @@ 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 { + async2 { // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds if cenv.compilingCanonicalFslibModuleType then let checkXmlDocs = cenv.diagnosticOptions.CheckXmlDocs @@ -5547,21 +5543,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) } @@ -5773,7 +5763,7 @@ let CheckOneImplFile let (ParsedImplFileInput (fileName, isScript, qualNameOfFile, _, implFileFrags, isLastCompiland, _, _)) = synImplFile let infoReader = InfoReader(g, amap) - cancellable { + async2 { use _ = Activity.start "CheckDeclarations.CheckOneImplFile" [| @@ -5798,7 +5788,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 @@ -5918,7 +5907,7 @@ let CheckOneImplFile /// Check an entire signature file let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSink, isInternalTestSpanStackReferring, diagnosticOptions) tcEnv (sigFile: ParsedSigFileInput) = - cancellable { + async2 { use _ = Activity.start "CheckDeclarations.CheckOneSigFile" [| @@ -5949,7 +5938,7 @@ let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSin try sigFileType |> IterTyconsOfModuleOrNamespaceType (fun tycon -> FinalTypeDefinitionChecksAtEndOfInferenceScope(cenv.infoReader, tcEnv.NameEnv, cenv.tcSink, false, tcEnv.DisplayEnv, tycon)) - with RecoverableException exn -> errorRecovery exn sigFile.QualifiedName.Range + with exn -> errorRecovery exn sigFile.QualifiedName.Range UpdatePrettyTyparNames.updateModuleOrNamespaceType sigFileType diff --git a/src/Compiler/Checking/CheckDeclarations.fsi b/src/Compiler/Checking/CheckDeclarations.fsi index 9b06fcc828..1a2be70f80 100644 --- a/src/Compiler/Checking/CheckDeclarations.fsi +++ b/src/Compiler/Checking/CheckDeclarations.fsi @@ -60,7 +60,7 @@ val CheckOneImplFile: ModuleOrNamespaceType option * ParsedImplFileInput * FSharpDiagnosticOptions -> - Cancellable + Async2 val CheckOneSigFile: TcGlobals * @@ -73,7 +73,7 @@ val CheckOneSigFile: FSharpDiagnosticOptions -> TcEnv -> ParsedSigFileInput -> - Cancellable + Async2 exception NotUpperCaseConstructor of range: range diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index fd6eabbf0f..ab15cee94a 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1225,8 +1225,8 @@ let CheckOneInput tcSink: TcResultsSink, tcState: TcState, input: ParsedInput - ) : Cancellable = - cancellable { + ) : Async2 = + async2 { try use _ = Activity.start "ParseAndCheckInputs.CheckOneInput" [| Activity.Tags.fileName, input.FileName |] @@ -1344,7 +1344,7 @@ let DiagnosticsLoggerForInput (tcConfig: TcConfig, oldLogger) = /// Typecheck a single file (or interactive entry into F# Interactive) let CheckOneInputEntry (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt) tcState input = - cancellable { + async2 { // Equip loggers to locally filter w.r.t. scope pragmas in each input use _ = UseTransformedDiagnosticsLogger(fun oldLogger -> DiagnosticsLoggerForInput(tcConfig, oldLogger)) @@ -1355,7 +1355,7 @@ let CheckOneInputEntry (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcG return! CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, input) } - |> Cancellable.runWithoutCancellation + |> Async2.runWithoutCancellation /// Finish checking multiple files (or one interactive entry into F# Interactive) let CheckMultipleInputsFinish (results, tcState: TcState) = @@ -1371,7 +1371,7 @@ let CheckMultipleInputsFinish (results, tcState: TcState) = (tcEnvAtEndOfLastFile, topAttrs, implFiles, ccuSigsForFiles), tcState let CheckOneInputAndFinish (checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) = - cancellable { + async2 { let! result, tcState = CheckOneInput(checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) let finishedResult = CheckMultipleInputsFinish([ result ], tcState) return finishedResult @@ -1445,8 +1445,8 @@ let CheckOneInputWithCallback _skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool ) - : Cancellable> = - cancellable { + : Async2> = + async2 { try CheckSimulateException tcConfig @@ -1820,7 +1820,7 @@ let CheckMultipleInputsUsingGraphMode : Finisher = let (Finisher(finisher = finisher)) = - cancellable { + async2 { use _ = UseDiagnosticsLogger logger let checkForErrors2 () = @@ -1833,7 +1833,7 @@ let CheckMultipleInputsUsingGraphMode node (checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false) } - |> Cancellable.runWithoutCancellation + |> Async2.runWithoutCancellation Finisher( node, diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fsi b/src/Compiler/Driver/ParseAndCheckInputs.fsi index 281638b568..6233cd17c1 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fsi +++ b/src/Compiler/Driver/ParseAndCheckInputs.fsi @@ -180,7 +180,7 @@ val CheckOneInput: tcSink: NameResolution.TcResultsSink * tcState: TcState * input: ParsedInput -> - Cancellable<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState> + Async2<(TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType) * TcState> val CheckOneInputWithCallback: node: NodeToTypeCheck -> @@ -193,7 +193,7 @@ val CheckOneInputWithCallback: tcState: TcState * input: ParsedInput * _skipImplIfSigExists: bool -> - Cancellable> + Async2> val AddCheckResultsToTcState: tcGlobals: TcGlobals * @@ -248,4 +248,4 @@ val CheckOneInputAndFinish: tcSink: NameResolution.TcResultsSink * tcState: TcState * input: ParsedInput -> - Cancellable<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState> + Async2<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState> diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 5db9b2e1b2..c130e15933 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -128,6 +128,7 @@ + diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index eb96a5f6e0..1ef603a2a9 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -909,10 +909,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 02471dd383..f545babce8 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/Interactive/fsi.fs b/src/Compiler/Interactive/fsi.fs index 8b09f86fb4..ed1143d386 100644 --- a/src/Compiler/Interactive/fsi.fs +++ b/src/Compiler/Interactive/fsi.fs @@ -4797,7 +4797,7 @@ type FsiEvaluationSession member _.ParseAndCheckInteraction(code) = fsiInteractionProcessor.ParseAndCheckInteraction(legacyReferenceResolver, fsiInteractionProcessor.CurrentState, code) - |> Cancellable.runWithoutCancellation + |> Async2.runWithoutCancellation member _.InteractiveChecker = checker diff --git a/src/Compiler/Service/BackgroundCompiler.fs b/src/Compiler/Service/BackgroundCompiler.fs index 1b00bcb1ff..b6ffa72ea9 100644 --- a/src/Compiler/Service/BackgroundCompiler.fs +++ b/src/Compiler/Service/BackgroundCompiler.fs @@ -330,7 +330,7 @@ type internal BackgroundCompiler | FSharpReferencedProject.PEReference(getStamp, delayedReader) -> { new IProjectReference with member x.EvaluateRawContents() = - cancellable { + async2 { let! ilReaderOpt = delayedReader.TryGetILModuleReader() match ilReaderOpt with @@ -343,7 +343,7 @@ type internal BackgroundCompiler // continue to try to use an on-disk DLL return ProjectAssemblyDataResult.Unavailable false } - |> Cancellable.toAsync + |> Async2.toAsync member x.TryGetLogicalTimeStamp _ = getStamp () |> Some member x.FileName = delayedReader.OutputFile @@ -352,13 +352,13 @@ type internal BackgroundCompiler | FSharpReferencedProject.ILModuleReference(nm, getStamp, getReader) -> { new IProjectReference with member x.EvaluateRawContents() = - cancellable { + async2 { let ilReader = getReader () let ilModuleDef, ilAsmRefs = ilReader.ILModuleDef, ilReader.ILAssemblyRefs let data = RawFSharpAssemblyData(ilModuleDef, ilAsmRefs) :> IRawFSharpAssemblyData return ProjectAssemblyDataResult.Available data } - |> Cancellable.toAsync + |> Async2.toAsync member x.TryGetLogicalTimeStamp _ = getStamp () |> Some member x.FileName = nm @@ -503,7 +503,7 @@ type internal BackgroundCompiler let getOrCreateBuilder (options, userOpName) : Async = async { - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() match tryGetBuilder options with | Some getBuilder -> @@ -745,7 +745,7 @@ type internal BackgroundCompiler keepAssemblyContents, suggestNamesForErrors ) - |> Cancellable.toAsync + |> Async2.toAsync GraphNode.SetPreferredUILang tcConfig.preferredUiLang return (parseResults, checkAnswer, sourceText.GetHashCode() |> int64, tcPrior.ProjectTimeStamp) @@ -1294,7 +1294,7 @@ type internal BackgroundCompiler "BackgroundCompiler.GetProjectOptionsFromScript" [| Activity.Tags.fileName, fileName; Activity.Tags.userOpName, _userOpName |] - cancellable { + async2 { // Do we add a reference to FSharp.Compiler.Interactive.Settings by default? let useFsiAuxLib = defaultArg useFsiAuxLib true let useSdkRefs = defaultArg useSdkRefs true @@ -1377,7 +1377,7 @@ type internal BackgroundCompiler return options, (diags @ diagnostics.Diagnostics) } - |> Cancellable.toAsync + |> Async2.toAsync member bc.InvalidateConfiguration(options: FSharpProjectOptions, userOpName) = use _ = diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index aa23d1534a..de6c9f4801 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -87,8 +87,8 @@ type DelayedILModuleReader = // fast path match box this.result with | null -> - cancellable { - let! ct = Cancellable.token () + async2 { + let ct = Async2.Token return lock this.gate (fun () -> @@ -118,7 +118,7 @@ type DelayedILModuleReader = None | _ -> Some this.result) } - | _ -> cancellable.Return(Some this.result) + | _ -> async2 { return Some this.result } [] type FSharpReferencedProject = @@ -3209,7 +3209,7 @@ module internal ParseAndCheckFile = suggestNamesForErrors: bool ) = - cancellable { + async2 { use _ = Activity.start "ParseAndCheckFile.CheckOneFile" @@ -3235,7 +3235,7 @@ module internal ParseAndCheckFile = let sink = TcResultsSinkImpl(tcGlobals, sourceText = sourceText) let! resOpt = - cancellable { + async2 { try let checkForErrors () = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) @@ -3683,7 +3683,7 @@ type FSharpCheckFileResults keepAssemblyContents: bool, suggestNamesForErrors: bool ) = - cancellable { + async2 { let! tcErrors, tcFileInfo = ParseAndCheckFile.CheckOneFile( parseResults, @@ -3923,7 +3923,7 @@ type FsiInteractiveChecker(legacyReferenceResolver, tcConfig: TcConfig, tcGlobal let keepAssemblyContents = false member _.ParseAndCheckInteraction(sourceText: ISourceText, ?userOpName: string) = - cancellable { + async2 { let userOpName = defaultArg userOpName "Unknown" let fileName = Path.Combine(tcConfig.implicitIncludeDir, "stdin.fsx") let suggestNamesForErrors = true // Will always be true, this is just for readability @@ -3931,7 +3931,7 @@ type FsiInteractiveChecker(legacyReferenceResolver, tcConfig: TcConfig, tcGlobal let parsingOptions = FSharpParsingOptions.FromTcConfig(tcConfig, [| fileName |], true) - let! ct = Cancellable.token () + let ct = Async2.Token let parseErrors, parsedInput, anyErrors = ParseAndCheckFile.parseFile ( diff --git a/src/Compiler/Service/FSharpCheckerResults.fsi b/src/Compiler/Service/FSharpCheckerResults.fsi index 9418d9a4f3..8aefb7f825 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fsi +++ b/src/Compiler/Service/FSharpCheckerResults.fsi @@ -46,7 +46,7 @@ type DelayedILModuleReader = /// Will lazily create the ILModuleReader. /// Is only evaluated once and can be called by multiple threads. - member internal TryGetILModuleReader: unit -> Cancellable + member internal TryGetILModuleReader: unit -> Async2 /// Unused in this API type public FSharpUnresolvedReferencesSet = internal FSharpUnresolvedReferencesSet of UnresolvedAssemblyReference list @@ -501,7 +501,7 @@ type public FSharpCheckFileResults = parseErrors: FSharpDiagnostic[] * keepAssemblyContents: bool * suggestNamesForErrors: bool -> - Cancellable + Async2 /// The result of calling TypeCheckResult including the possibility of abort and background compiler not caught up. and [] public FSharpCheckFileAnswer = @@ -618,7 +618,7 @@ type internal FsiInteractiveChecker = member internal ParseAndCheckInteraction: sourceText: ISourceText * ?userOpName: string -> - Cancellable + Async2 module internal FSharpCheckerResultsSettings = val defaultFSharpBinariesDir: string diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index 6db19653f9..cf171e78f0 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -272,7 +272,7 @@ type BoundModel private ( None, TcResultsSink.WithSink sink, prevTcInfo.tcState, input ) - |> Cancellable.toAsync + |> Async2.toAsync fileChecked.Trigger fileName diff --git a/src/Compiler/Service/ServiceAnalysis.fs b/src/Compiler/Service/ServiceAnalysis.fs index 6455d9f0ff..43f9110085 100644 --- a/src/Compiler/Service/ServiceAnalysis.fs +++ b/src/Compiler/Service/ServiceAnalysis.fs @@ -302,7 +302,7 @@ module UnusedOpens = /// Async to allow cancellation. let getUnusedOpens (checkFileResults: FSharpCheckFileResults, getSourceLineStr: int -> string) : Async = async { - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() if checkFileResults.OpenDeclarations.Length = 0 then return [] diff --git a/src/Compiler/Service/TransparentCompiler.fs b/src/Compiler/Service/TransparentCompiler.fs index 0c3f01d4a3..8472c47af7 100644 --- a/src/Compiler/Service/TransparentCompiler.fs +++ b/src/Compiler/Service/TransparentCompiler.fs @@ -771,7 +771,7 @@ type internal TransparentCompiler | FSharpReferencedProjectSnapshot.PEReference(getStamp, delayedReader) -> { new IProjectReference with member x.EvaluateRawContents() = - cancellable { + async2 { let! ilReaderOpt = delayedReader.TryGetILModuleReader() match ilReaderOpt with @@ -784,7 +784,7 @@ type internal TransparentCompiler // continue to try to use an on-disk DLL return ProjectAssemblyDataResult.Unavailable false } - |> Cancellable.toAsync + |> Async2.toAsync member x.TryGetLogicalTimeStamp _ = getStamp () |> Some member x.FileName = delayedReader.OutputFile @@ -793,13 +793,13 @@ type internal TransparentCompiler | FSharpReferencedProjectSnapshot.ILModuleReference(nm, getStamp, getReader) -> { new IProjectReference with member x.EvaluateRawContents() = - cancellable { + async2 { let ilReader = getReader () let ilModuleDef, ilAsmRefs = ilReader.ILModuleDef, ilReader.ILAssemblyRefs let data = RawFSharpAssemblyData(ilModuleDef, ilAsmRefs) :> IRawFSharpAssemblyData return ProjectAssemblyDataResult.Available data } - |> Cancellable.toAsync + |> Async2.toAsync member x.TryGetLogicalTimeStamp _ = getStamp () |> Some member x.FileName = nm @@ -1431,7 +1431,7 @@ type internal TransparentCompiler prevTcInfo.tcState, input, true) - |> Cancellable.toAsync + |> Async2.toAsync //fileChecked.Trigger fileName @@ -1608,7 +1608,7 @@ type internal TransparentCompiler caches.ParseAndCheckFileInProject.Get( projectSnapshot.FileKeyWithExtraFileSnapshotVersion fileName, async { - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() use _ = Activity.start "ComputeParseAndCheckFileInProject" [| Activity.Tags.fileName, fileName |> Path.GetFileName |> (!!) |] @@ -1876,7 +1876,7 @@ type internal TransparentCompiler Activity.Tags.project, projectSnapshot.ProjectFileName |> Path.GetFileName |> (!!) |] - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() try @@ -1924,7 +1924,7 @@ type internal TransparentCompiler caches.ParseAndCheckProject.Get( projectSnapshot.FullKey, async { - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() match! ComputeBootstrapInfo projectSnapshot with | None, creationDiags -> @@ -1998,7 +1998,7 @@ type internal TransparentCompiler let tryGetSink (fileName: string) (projectSnapshot: ProjectSnapshot) = async { - use! _holder = Cancellable.UseToken() + use! _holder = Async2.UseTokenAsync() match! ComputeBootstrapInfo projectSnapshot with | None, _ -> return None diff --git a/src/Compiler/Utilities/Async2.fs b/src/Compiler/Utilities/Async2.fs new file mode 100644 index 0000000000..8fcf7d96ff --- /dev/null +++ b/src/Compiler/Utilities/Async2.fs @@ -0,0 +1,435 @@ +namespace Internal.Utilities.Library + +open System +open System.Threading +open System.Threading.Tasks + +#nowarn 3513 + +type internal Async2 = + static let token = AsyncLocal() + + static member UseToken ct = + let old = token.Value + token.Value <- ct + + { new IDisposable with + member _.Dispose() = token.Value <- old + } + + static member UseTokenAsync() = + async { + let! ct = Async.CancellationToken + let old = token.Value + token.Value <- ct + + return + { new IDisposable with + member _.Dispose() = token.Value <- old + } + } + + static member val Token = token.Value + +module internal Async2Implementation = + + open FSharp.Core.CompilerServices.StateMachineHelpers + + open Microsoft.FSharp.Core.CompilerServices + open System.Runtime.CompilerServices + open System.Runtime.ExceptionServices + + /// A structure that looks like an Awaiter + type Awaiter<'Awaiter, 'TResult + when 'Awaiter :> ICriticalNotifyCompletion + and 'Awaiter: (member get_IsCompleted: unit -> bool) + and 'Awaiter: (member GetResult: unit -> 'TResult)> = 'Awaiter + + type Awaitable<'Awaitable, 'Awaiter, 'TResult when 'Awaitable: (member GetAwaiter: unit -> Awaiter<'Awaiter, 'TResult>)> = 'Awaitable + + module Awaiter = + let inline isCompleted (awaiter: ^Awaiter) : bool when ^Awaiter: (member get_IsCompleted: unit -> bool) = awaiter.get_IsCompleted () + + let inline getResult (awaiter: ^Awaiter) : ^TResult when ^Awaiter: (member GetResult: unit -> ^TResult) = awaiter.GetResult() + + let inline onCompleted (awaiter: ^Awaiter) (continuation: Action) : unit when ^Awaiter :> INotifyCompletion = + awaiter.OnCompleted continuation + + let inline unsafeOnCompleted (awaiter: ^Awaiter) (continuation: Action) : unit when ^Awaiter :> ICriticalNotifyCompletion = + awaiter.UnsafeOnCompleted continuation + + type Trampoline private () = + + let failIfNot condition message = + if not condition then + failwith message + + let ownerThreadId = Thread.CurrentThread.ManagedThreadId + + static let holder = new ThreadLocal<_>(fun () -> Trampoline()) + + let mutable pending: Action voption = ValueNone + let mutable running = false + + let start (action: Action) = + try + running <- true + action.Invoke() + + while pending.IsSome do + let next = pending.Value + pending <- ValueNone + next.Invoke() + finally + running <- false + + let set action = + failIfNot (Thread.CurrentThread.ManagedThreadId = ownerThreadId) "Trampoline used from wrong thread" + failIfNot pending.IsNone "Trampoline used while already pending" + + if running then + pending <- ValueSome action + else + start action + + interface ICriticalNotifyCompletion with + member _.OnCompleted(continuation) = set continuation + member _.UnsafeOnCompleted(continuation) = set continuation + + member this.Ref: ICriticalNotifyCompletion ref = ref this + + static member Current = holder.Value + + [] + type DynamicContinuation = + | Stop + | Immediate + | Bounce + | Await of ICriticalNotifyCompletion + + [] + type DynamicState = + | InitialYield + | Running + | SetResult + | SetException of ExceptionDispatchInfo + + module BindContext = + [] + let bindLimit = 100 + + let bindCount = new ThreadLocal() + + let inline ResetBindCount () = bindCount.Value <- 0 + + let inline IncrementBindCount () = + bindCount.Value <- bindCount.Value + 1 + bindCount.Value % bindLimit = 0 + + let inline IncrementBindCountDynamic () = + if IncrementBindCount() then Bounce else Immediate + + module ExceptionCache = + let store = ConditionalWeakTable() + + let inline CaptureOrRetrieve (exn: exn) = + match store.TryGetValue exn with + | true, edi when edi.SourceException = exn -> edi + | _ -> + let edi = ExceptionDispatchInfo.Capture exn + + try + store.Add(exn, edi) + with _ -> + () + + edi + + let inline Throw (exn: exn) = + let edi = CaptureOrRetrieve exn + edi.Throw() + Unchecked.defaultof<_> + + let inline GetResultOrThrow awaiter = + try + Awaiter.getResult awaiter + with exn -> + Throw exn + + [] + type internal Async2<'T>(start: unit -> Task<'T>) = + + member inline _.Start() = start () + + [] + type Async2Data<'t> = + [] + val mutable Result: 't + + [] + val mutable MethodBuilder: AsyncTaskMethodBuilder<'t> + + [] + val mutable Hijack: bool + + type Async2StateMachine<'TOverall> = ResumableStateMachine> + type IAsync2StateMachine<'TOverall> = IResumableStateMachine> + type Async2ResumptionFunc<'TOverall> = ResumptionFunc> + type Async2ResumptionDynamicInfo<'TOverall> = ResumptionDynamicInfo> + type Async2Code<'TOverall, 'T> = ResumableCode, 'T> + + [] + module Async2Code = + let inline filterCancellation (catch: exn -> Async2Code<_, _>) (exn: exn) = + Async2Code(fun sm -> + match exn with + | :? OperationCanceledException as oce when oce.CancellationToken = Async2.Token -> raise exn + | _ -> (catch exn).Invoke(&sm)) + + let inline throwIfCancellationRequested (code: Async2Code<_, _>) = + Async2Code(fun sm -> + Async2.Token.ThrowIfCancellationRequested() + code.Invoke(&sm)) + + let inline yieldOnBindLimit () = + Async2Code<_, _>(fun sm -> + if BindContext.IncrementBindCount() then + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + + if not __stack_yield_fin then + sm.Data.MethodBuilder.AwaitOnCompleted(Trampoline.Current.Ref, &sm) + + __stack_yield_fin + else + true) + + type Async2Builder() = + + member inline _.Delay(generator: unit -> Async2Code<'TOverall, 'T>) : Async2Code<'TOverall, 'T> = + ResumableCode.Delay(fun () -> generator () |> throwIfCancellationRequested) + + [] + member inline _.Zero() : Async2Code<'TOverall, unit> = ResumableCode.Zero() + + member inline _.Return(value: 'T) = + Async2Code(fun sm -> + sm.Data.Result <- value + true) + + member inline _.Combine(code1: Async2Code<'TOverall, unit>, code2: Async2Code<'TOverall, 'T>) : Async2Code<'TOverall, 'T> = + ResumableCode.Combine(code1, code2) + + member inline _.While([] condition: unit -> bool, body: Async2Code<'TOverall, unit>) : Async2Code<'TOverall, unit> = + ResumableCode.While(condition, throwIfCancellationRequested body) + + member inline _.TryWith + (body: Async2Code<'TOverall, 'T>, [] catch: exn -> Async2Code<'TOverall, 'T>) + : Async2Code<'TOverall, 'T> = + ResumableCode.TryWith(body, filterCancellation catch) + + member inline _.TryFinally + (body: Async2Code<'TOverall, 'T>, [] compensation: unit -> unit) + : Async2Code<'TOverall, 'T> = + ResumableCode.TryFinally( + body, + ResumableCode<_, _>(fun _sm -> + compensation () + true) + ) + + member inline _.Using<'Resource, 'TOverall, 'T when 'Resource :> IDisposable | null> + (resource: 'Resource, body: 'Resource -> Async2Code<'TOverall, 'T>) + : Async2Code<'TOverall, 'T> = + ResumableCode.Using(resource, body) + + member inline _.For(sequence: seq<'T>, [] body: 'T -> Async2Code<'TOverall, unit>) : Async2Code<'TOverall, unit> = + ResumableCode.For(sequence, fun x -> body x |> throwIfCancellationRequested) + + [] + static member inline BindDynamic + (sm: byref>, awaiter, [] continuation: _ -> Async2Code<_, _>) + = + if Awaiter.isCompleted awaiter then + (Awaiter.getResult awaiter |> continuation).Invoke(&sm) + else + let resumptionFunc = + Async2ResumptionFunc(fun sm -> + let result = ExceptionCache.GetResultOrThrow awaiter + (continuation result).Invoke(&sm)) + + sm.ResumptionDynamicInfo.ResumptionFunc <- resumptionFunc + sm.ResumptionDynamicInfo.ResumptionData <- awaiter :> ICriticalNotifyCompletion + false + + [] + member inline _.Bind(awaiter, [] continuation: 'U -> Async2Code<'Data, 'T>) : Async2Code<'Data, 'T> = + Async2Code(fun sm -> + if __useResumableCode then + if Awaiter.isCompleted awaiter then + continuation(ExceptionCache.GetResultOrThrow awaiter).Invoke(&sm) + else + let __stack_yield_fin = ResumableCode.Yield().Invoke(&sm) + + if __stack_yield_fin then + continuation(ExceptionCache.GetResultOrThrow awaiter).Invoke(&sm) + else + let mutable __stack_awaiter = awaiter + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&__stack_awaiter, &sm) + false + else + Async2Builder.BindDynamic(&sm, awaiter, continuation)) + + [] + member inline this.ReturnFrom(awaiter) : Async2Code<'T, 'T> = this.Bind(awaiter, this.Return) + + static member inline RunDynamic(code: Async2Code<'T, 'T>) : Async2<'T> = + let initialResumptionFunc = Async2ResumptionFunc<'T>(fun sm -> code.Invoke &sm) + + let resumptionInfo () = + let mutable state = InitialYield + + { new Async2ResumptionDynamicInfo<'T>(initialResumptionFunc) with + member info.MoveNext(sm) = + let mutable continuation = Stop + + let current = state + + match current with + | InitialYield -> + state <- Running + continuation <- BindContext.IncrementBindCountDynamic() + | Running -> + try + let step = info.ResumptionFunc.Invoke(&sm) + + if step then + state <- SetResult + continuation <- BindContext.IncrementBindCountDynamic() + else + match info.ResumptionData with + | :? ICriticalNotifyCompletion as awaiter -> continuation <- Await awaiter + | _ -> failwith "invalid awaiter" + with exn -> + state <- SetException(ExceptionCache.CaptureOrRetrieve exn) + continuation <- BindContext.IncrementBindCountDynamic() + | SetResult -> sm.Data.MethodBuilder.SetResult sm.Data.Result + | SetException edi -> sm.Data.MethodBuilder.SetException(edi.SourceException) + + let continuation = continuation + + match continuation with + | Await awaiter -> + sm.ResumptionDynamicInfo.ResumptionData <- null + let mutable awaiter = awaiter + sm.Data.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + | Bounce -> sm.Data.MethodBuilder.AwaitOnCompleted(Trampoline.Current.Ref, &sm) + | Immediate -> info.MoveNext &sm + | Stop -> () + + member _.SetStateMachine(sm, state) = + sm.Data.MethodBuilder.SetStateMachine(state) + } + + Async2(fun () -> + let mutable copy = Async2StateMachine() + copy.ResumptionDynamicInfo <- resumptionInfo () + copy.Data <- Async2Data() + copy.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + copy.Data.MethodBuilder.Start(©) + copy.Data.MethodBuilder.Task) + + member inline _.Run(code: Async2Code<'T, 'T>) : Async2<'T> = + if __useResumableCode then + __stateMachine, _> + + (MoveNextMethodImpl<_>(fun sm -> + __resumeAt sm.ResumptionPoint + let mutable error = ValueNone + + let __stack_go1 = yieldOnBindLimit().Invoke(&sm) + + if __stack_go1 then + try + let __stack_code_fin = code.Invoke(&sm) + + if __stack_code_fin then + let __stack_go2 = yieldOnBindLimit().Invoke(&sm) + + if __stack_go2 then + sm.Data.MethodBuilder.SetResult(sm.Data.Result) + with exn -> + error <- ValueSome(ExceptionCache.CaptureOrRetrieve exn) + + if error.IsSome then + let __stack_go2 = yieldOnBindLimit().Invoke(&sm) + + if __stack_go2 then + sm.Data.MethodBuilder.SetException(error.Value.SourceException))) + + (SetStateMachineMethodImpl<_>(fun sm state -> sm.Data.MethodBuilder.SetStateMachine state)) + + (AfterCode<_, _>(fun sm -> + let mutable copy = sm + + Async2(fun () -> + copy.Data <- Async2Data() + copy.Data.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + copy.Data.MethodBuilder.Start(©) + copy.Data.MethodBuilder.Task))) + else + Async2Builder.RunDynamic(code) + + member inline _.Source(code: Async2<_>) = code.Start().GetAwaiter() + +[] +module internal Async2AutoOpens = + open Async2Implementation + + let async2 = Async2Builder() + +[] +module internal Async2LowPriority = + open Async2Implementation + + type Async2Builder with + member inline _.Source(awaitable: Awaitable<_, _, _>) = awaitable.GetAwaiter() + member inline _.Source(expr: Async<_>) = Async.StartAsTask(expr, cancellationToken = Async2.Token).GetAwaiter() + member inline _.Source(items: #seq<_>) : seq<_> = upcast items + +[] +module internal Async2MediumPriority = + open Async2Implementation + type Async2Builder with + member inline _.Source(task: Task) = task.GetAwaiter() + member inline _.Source(task: Task<_>) = task.GetAwaiter() + +open Async2Implementation + +type internal Async2<'t> = Async2Implementation.Async2<'t> + +module internal Async2 = + + let run ct (code: Async2<'t>) = + use _ = Async2.UseToken ct + + if + isNull SynchronizationContext.Current + && TaskScheduler.Current = TaskScheduler.Default + then + BindContext.ResetBindCount() + code.Start().GetAwaiter().GetResult() + else + Task + .Run<'t>(fun () -> + BindContext.ResetBindCount() + code.Start()) + .GetAwaiter() + .GetResult() + + let startAsTask (code: Async2<'t>) = + BindContext.ResetBindCount() + code.Start() + + let runWithoutCancellation code = run CancellationToken.None code + + let toAsync (code: Async2<_>) = startAsTask code |> Async.AwaitTask diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index bae9c6f829..33b8448688 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -1,226 +1,11 @@ namespace FSharp.Compiler -open System +open Internal.Utilities.Library open System.Threading -// This code provides two methods for handling cancellation in synchronous code: -// 1. Explicitly, by calling Cancellable.CheckAndThrow(). -// 2. Implicitly, by wrapping the code in a cancellable computation. -// The cancellable computation propagates the CancellationToken and checks for cancellation implicitly. -// When it is impractical to use the cancellable computation, such as in deeply nested functions, Cancellable.CheckAndThrow() can be used. -// It checks a CancellationToken local to the current async execution context, held in AsyncLocal. -// Before calling Cancellable.CheckAndThrow(), this token must be set. -// The token is guaranteed to be set during execution of cancellable computation. -// Otherwise, it can be passed explicitly from the ambient async computation using Cancellable.UseToken(). - [] type Cancellable = - static let tokenHolder = AsyncLocal() - - static let guard = - String.IsNullOrWhiteSpace(Environment.GetEnvironmentVariable("DISABLE_CHECKANDTHROW_ASSERT")) - - 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 UseToken() = - async { - let! ct = Async.CancellationToken - return Cancellable.UsingToken ct - } - - static member UsingToken(ct) = - let oldCt = tokenHolder.Value - tokenHolder.Value <- ValueSome ct - - { new IDisposable with - member _.Dispose() = tokenHolder.Value <- oldCt - } - static member CheckAndThrow() = - let token = ensureToken "CheckAndThrow invoked outside of Cancellable computation." - token.ThrowIfCancellationRequested() - - static member TryCheckAndThrow() = - match tokenHolder.Value with - | ValueNone -> () - | ValueSome token -> token.ThrowIfCancellationRequested() - -namespace Internal.Utilities.Library - -open System -open System.Threading -open FSharp.Compiler - -open FSharp.Core.CompilerServices.StateMachineHelpers - -[] -type ValueOrCancelled<'TResult> = - | Value of result: 'TResult - | Cancelled of ``exception``: OperationCanceledException - -[] -type Cancellable<'T> = Cancellable of (CancellationToken -> ValueOrCancelled<'T>) - -module Cancellable = - - 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 - - let fold f acc seq = - Cancellable(fun ct -> - let mutable acc = ValueOrCancelled.Value acc - - for x in seq do - match acc with - | ValueOrCancelled.Value accv -> acc <- run ct (f accv x) - | ValueOrCancelled.Cancelled _ -> () - - acc) - - let runWithoutCancellation comp = - use _ = Cancellable.UsingToken CancellationToken.None - let res = run CancellationToken.None comp - - match res with - | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" - | ValueOrCancelled.Value r -> r - - 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 token () = Cancellable(ValueOrCancelled.Value) - -type CancellableBuilder() = - - member inline _.Delay([] f) = - Cancellable(fun ct -> - let (Cancellable g) = f () - g ct) - - member inline _.Bind(comp, [] k) = - Cancellable(fun ct -> - - __debugPoint "" - - match Cancellable.run ct comp with - | ValueOrCancelled.Value v1 -> Cancellable.run ct (k v1) - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) - - member inline _.BindReturn(comp, [] k) = - Cancellable(fun ct -> - - __debugPoint "" - - match Cancellable.run ct comp with - | ValueOrCancelled.Value v1 -> ValueOrCancelled.Value(k v1) - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) - - member inline _.Combine(comp1, comp2) = - Cancellable(fun ct -> - - __debugPoint "" - - match Cancellable.run ct comp1 with - | ValueOrCancelled.Value() -> Cancellable.run ct comp2 - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) - - member inline _.TryWith(comp, [] handler) = - Cancellable(fun ct -> - - __debugPoint "" - - 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) - - 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 inline _.Using(resource: _ MaybeNull, [] comp) = - Cancellable(fun ct -> - - __debugPoint "" - - let body = comp resource - - 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) - - match compRes with - | ValueOrCancelled.Value res -> - Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.Dispose resource - - match res with - | Choice1Of2 r -> ValueOrCancelled.Value r - | Choice2Of2 err -> raise err - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) - - member inline _.TryFinally(comp, [] compensation) = - Cancellable(fun ct -> - - __debugPoint "" - - 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) - - match compRes with - | ValueOrCancelled.Value res -> - compensation () - - match res with - | Choice1Of2 r -> ValueOrCancelled.Value r - | Choice2Of2 err -> raise err - | ValueOrCancelled.Cancelled err1 -> ValueOrCancelled.Cancelled err1) - - member inline _.Return v = - Cancellable(fun _ -> ValueOrCancelled.Value v) - - member inline _.ReturnFrom(v: Cancellable<'T>) = v - - member inline _.Zero() = - Cancellable(fun _ -> ValueOrCancelled.Value()) - -[] -module CancellableAutoOpens = - let cancellable = CancellableBuilder() + // If we're not inside an async computation, the ambient cancellation token will be CancellationToken.None and nothing will happen + // otherwise, if we are inside an async computation, this will throw. + Async2.Token.ThrowIfCancellationRequested() diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 0d82faa68c..ea928cd075 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -1,79 +1,5 @@ namespace FSharp.Compiler -open System -open System.Threading - [] type Cancellable = - static member internal UseToken: unit -> Async - - static member HasCancellationToken: bool - static member Token: CancellationToken - static member CheckAndThrow: unit -> unit - static member TryCheckAndThrow: unit -> unit - -namespace Internal.Utilities.Library - -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>) - -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> - - /// 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 - - /// Bind the cancellation token associated with the computation - val token: unit -> Cancellable - - val toAsync: Cancellable<'T> -> Async<'T> - -type internal CancellableBuilder = - - new: unit -> CancellableBuilder - - member inline BindReturn: comp: Cancellable<'T> * [] k: ('T -> 'U) -> Cancellable<'U> - - member inline Bind: comp: Cancellable<'T> * [] k: ('T -> Cancellable<'U>) -> Cancellable<'U> - - member inline Combine: comp1: Cancellable * comp2: Cancellable<'T> -> Cancellable<'T> - - member inline Delay: [] f: (unit -> Cancellable<'T>) -> Cancellable<'T> - - member inline Return: v: 'T -> Cancellable<'T> - - member inline ReturnFrom: v: Cancellable<'T> -> Cancellable<'T> - - member inline TryFinally: comp: Cancellable<'T> * [] compensation: (unit -> unit) -> Cancellable<'T> - - member inline TryWith: - comp: Cancellable<'T> * [] handler: (exn -> Cancellable<'T>) -> Cancellable<'T> - - member inline Using: - resource: 'Resource MaybeNull * [] comp: ('Resource MaybeNull -> Cancellable<'T>) -> - Cancellable<'T> - when 'Resource :> IDisposable and 'Resource: not struct and 'Resource: not null - - member inline Zero: unit -> Cancellable - -[] -module internal CancellableAutoOpens = - val cancellable: CancellableBuilder diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl index bc08c7fd0b..4a60d33db6 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl @@ -2011,12 +2011,7 @@ FSharp.Compiler.AbstractIL.ILBinaryReader: FSharp.Compiler.AbstractIL.ILBinaryRe FSharp.Compiler.AbstractIL.ILBinaryReader: FSharp.Compiler.AbstractIL.ILBinaryReader+MetadataOnlyFlag FSharp.Compiler.AbstractIL.ILBinaryReader: FSharp.Compiler.AbstractIL.ILBinaryReader+ReduceMemoryFlag FSharp.Compiler.AbstractIL.ILBinaryReader: FSharp.Compiler.AbstractIL.ILBinaryReader+Shim -FSharp.Compiler.Cancellable: Boolean HasCancellationToken -FSharp.Compiler.Cancellable: Boolean get_HasCancellationToken() -FSharp.Compiler.Cancellable: System.Threading.CancellationToken Token -FSharp.Compiler.Cancellable: System.Threading.CancellationToken get_Token() FSharp.Compiler.Cancellable: Void CheckAndThrow() -FSharp.Compiler.Cancellable: Void TryCheckAndThrow() FSharp.Compiler.CodeAnalysis.DelayedILModuleReader: System.String OutputFile FSharp.Compiler.CodeAnalysis.DelayedILModuleReader: System.String get_OutputFile() FSharp.Compiler.CodeAnalysis.DelayedILModuleReader: Void .ctor(System.String, Microsoft.FSharp.Core.FSharpFunc`2[System.Threading.CancellationToken,Microsoft.FSharp.Core.FSharpOption`1[System.IO.Stream]]) diff --git a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs index f307586cd5..d8988c1099 100644 --- a/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ModuleReaderCancellationTests.fs @@ -150,7 +150,7 @@ let parseAndCheck path source options = | _, FSharpCheckFileAnswer.Aborted -> None | _, FSharpCheckFileAnswer.Succeeded results -> Some results - Cancellable.HasCancellationToken |> shouldEqual false + Async2.Token |> shouldEqual CancellationToken.None result with :? OperationCanceledException -> @@ -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