From 78dae4f3baa5b136d918ce4c299d2c50f4fcdd62 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Tue, 17 Oct 2023 16:54:05 +0200 Subject: [PATCH 01/12] Move Cancellable to a separate file --- src/Compiler/FSharp.Compiler.Service.fsproj | 2 + src/Compiler/Utilities/Cancellable.fs | 170 +++++++++++++++++++ src/Compiler/Utilities/Cancellable.fsi | 63 +++++++ src/Compiler/Utilities/illib.fs | 174 -------------------- src/Compiler/Utilities/illib.fsi | 59 ------- 5 files changed, 235 insertions(+), 233 deletions(-) create mode 100644 src/Compiler/Utilities/Cancellable.fs create mode 100644 src/Compiler/Utilities/Cancellable.fsi diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 45ae22a3e54..d673dec4d5c 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -106,6 +106,8 @@ + + diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs new file mode 100644 index 00000000000..9e825837bdb --- /dev/null +++ b/src/Compiler/Utilities/Cancellable.fs @@ -0,0 +1,170 @@ +namespace Internal.Utilities.Library + +open System +open System.Threading + +[] +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 + oper ct + + 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 = + let res = run CancellationToken.None comp + + match res with + | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" + | ValueOrCancelled.Value r -> r + + let toAsync c = + async { + let! ct = Async.CancellationToken + let res = run ct c + + return! + Async.FromContinuations(fun (cont, _econt, ccont) -> + match res with + | ValueOrCancelled.Value v -> cont v + | ValueOrCancelled.Cancelled ce -> ccont ce) + } + + let token () = + Cancellable(fun ct -> ValueOrCancelled.Value ct) + +type CancellableBuilder() = + + member inline _.Delay([] f) = + Cancellable(fun ct -> + let (Cancellable g) = f () + g ct) + + member inline _.Bind(comp, [] k) = + Cancellable(fun ct -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + + 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 -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + + 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 -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + + 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 -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + + 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, [] comp) = + Cancellable(fun ct -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + 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 -> +#if !FSHARPCORE_USE_PACKAGE + __debugPoint "" +#endif + + 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() diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi new file mode 100644 index 00000000000..7a5054278b4 --- /dev/null +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -0,0 +1,63 @@ +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 * [] comp: ('Resource -> Cancellable<'T>) -> Cancellable<'T> + when 'Resource :> IDisposable + + member inline Zero: unit -> Cancellable + +[] +module internal CancellableAutoOpens = + val cancellable: CancellableBuilder diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index a0db105d145..fd3c51e5a99 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -873,180 +873,6 @@ module ResultOrException = | Result x -> success x | Exception _err -> f () -[] -type ValueOrCancelled<'TResult> = - | Value of result: 'TResult - | Cancelled of ``exception``: OperationCanceledException - -/// Represents a cancellable computation with explicit representation of a cancelled result. -/// -/// A cancellable computation is passed 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 Cancellable<'T> = Cancellable of (CancellationToken -> ValueOrCancelled<'T>) - -module Cancellable = - - /// Run a cancellable computation using the given cancellation token - let inline run (ct: CancellationToken) (Cancellable oper) = - if ct.IsCancellationRequested then - ValueOrCancelled.Cancelled(OperationCanceledException ct) - else - oper ct - - 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) - - /// Run the computation in a mode where it may not be cancelled. The computation never results in a - /// ValueOrCancelled.Cancelled. - let runWithoutCancellation comp = - let res = run CancellationToken.None comp - - match res with - | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" - | ValueOrCancelled.Value r -> r - - let toAsync c = - async { - let! ct = Async.CancellationToken - let res = run ct c - - return! - Async.FromContinuations(fun (cont, _econt, ccont) -> - match res with - | ValueOrCancelled.Value v -> cont v - | ValueOrCancelled.Cancelled ce -> ccont ce) - } - - /// Bind the cancellation token associated with the computation - let token () = - Cancellable(fun ct -> ValueOrCancelled.Value ct) - -type CancellableBuilder() = - - member inline _.Delay([] f) = - Cancellable(fun ct -> - let (Cancellable g) = f () - g ct) - - member inline _.Bind(comp, [] k) = - Cancellable(fun ct -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - - 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 -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - - 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 -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - - 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 -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - - 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, [] comp) = - Cancellable(fun ct -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - 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 -> -#if !FSHARPCORE_USE_PACKAGE - __debugPoint "" -#endif - - 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() - /// Generates unique stamps type UniqueStampGenerator<'T when 'T: equality>() = let encodeTable = ConcurrentDictionary<'T, Lazy>(HashIdentity.Structural) diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index bb41d9c490f..8232f33df4f 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -369,65 +369,6 @@ module internal ResultOrException = val otherwise: f: (unit -> ResultOrException<'a>) -> x: ResultOrException<'a> -> ResultOrException<'a> -[] -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 * [] comp: ('Resource -> Cancellable<'T>) -> Cancellable<'T> - when 'Resource :> IDisposable - - member inline Zero: unit -> Cancellable - -[] -module internal CancellableAutoOpens = - val cancellable: CancellableBuilder - /// Generates unique stamps type internal UniqueStampGenerator<'T when 'T: equality> = From cddac92b54ad5a952e52d0813710adc0e3894601 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Tue, 17 Oct 2023 21:28:35 +0200 Subject: [PATCH 02/12] Allow checking cancellation inside analysis --- .../Checking/PatternMatchCompilation.fs | 2 + src/Compiler/Facilities/DiagnosticsLogger.fs | 2 + src/Compiler/Utilities/Cancellable.fs | 43 ++++++++++++++++++- src/Compiler/Utilities/Cancellable.fsi | 12 ++++++ 4 files changed, 58 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index 511b56f8eb2..7e22a4635c5 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -1146,6 +1146,8 @@ let CompilePatternBasic // The main recursive loop of the pattern match compiler. let rec InvestigateFrontiers refuted frontiers = + Cancellable.CheckAndThrow() + match frontiers with | [] -> failwith "CompilePattern: compile - empty clauses: at least the final clause should always succeed" | Frontier (i, active, valMap) :: rest -> diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index b1edce3f820..342d9ce5b70 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -857,11 +857,13 @@ type StackGuard(maxDepth: int, name: string) = if depth % maxDepth = 0 then let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger let buildPhase = DiagnosticsThreadStatics.BuildPhase + let ct = Cancellable.Token async { do! Async.SwitchToNewThread() Thread.CurrentThread.Name <- $"F# Extra Compilation Thread for {name} (depth {depth})" use _scope = new CompilationGlobalsScope(diagnosticsLogger, buildPhase) + use _token = Cancellable.UsingToken ct return f () } |> Async.RunImmediate diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 9e825837bdb..82cac9ef74d 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -1,7 +1,44 @@ +namespace FSharp.Compiler + +open System +open System.Threading +open Internal.Utilities.Library + +[] +type Cancellable = + [] + static val mutable private tokens: CancellationToken list + + static member private Tokens + with get () = + match box Cancellable.tokens with + | Null -> [] + | _ -> Cancellable.tokens + and set v = Cancellable.tokens <- v + + static member UsingToken(ct) = + Cancellable.Tokens <- ct :: Cancellable.Tokens + + { new IDisposable with + member this.Dispose() = + Cancellable.Tokens <- Cancellable.Tokens |> List.tail } + + static member Token = + match Cancellable.Tokens with + | [] -> CancellationToken.None + | token :: _ -> token + + static member CheckAndThrow() = + match Cancellable.Tokens with + | [] -> () + | token :: _ -> token.ThrowIfCancellationRequested() + + namespace Internal.Utilities.Library open System open System.Threading +open FSharp.Compiler [] type ValueOrCancelled<'TResult> = @@ -17,7 +54,11 @@ module Cancellable = if ct.IsCancellationRequested then ValueOrCancelled.Cancelled(OperationCanceledException ct) else - oper ct + try + use _ = Cancellable.UsingToken(ct) + oper ct + with :? OperationCanceledException as e -> + ValueOrCancelled.Cancelled(OperationCanceledException e.CancellationToken) let fold f acc seq = Cancellable(fun ct -> diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 7a5054278b4..122f75046aa 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -1,3 +1,15 @@ +namespace FSharp.Compiler + +open System +open System.Threading + +[] +type Cancellable = + static member internal UsingToken: CancellationToken -> IDisposable + static member Token: CancellationToken + static member CheckAndThrow: unit -> unit + + namespace Internal.Utilities.Library open System From 78707cf44ae21db86ff9708a15b630245f5b57cc Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 18 Oct 2023 15:58:44 +0200 Subject: [PATCH 03/12] Don't recover on OCE during analysis --- src/Compiler/Checking/CheckDeclarations.fs | 36 ++++++++++---------- src/Compiler/Checking/CheckExpressions.fs | 10 +++--- src/Compiler/Checking/CheckPatterns.fs | 10 +++--- src/Compiler/Checking/MethodOverrides.fs | 2 +- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 2 +- src/Compiler/Driver/CompilerConfig.fs | 4 +-- src/Compiler/Driver/CompilerImports.fs | 4 +-- src/Compiler/Driver/CompilerOptions.fs | 2 +- src/Compiler/Driver/ParseAndCheckInputs.fs | 16 ++++----- src/Compiler/Driver/ScriptClosure.fs | 2 +- src/Compiler/Optimize/Optimizer.fs | 2 +- src/Compiler/Symbols/FSharpDiagnostic.fs | 2 +- src/Compiler/TypedTree/TypeProviders.fs | 2 +- src/Compiler/Utilities/Cancellable.fs | 7 ++++ src/Compiler/Utilities/Cancellable.fsi | 5 +++ 16 files changed, 60 insertions(+), 48 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 1c0997851e4..48c74686630 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -1190,7 +1190,7 @@ module MutRecBindingChecking = let inheritsExpr, tpenv = try TcNewExpr cenv envInstance tpenv baseTy (Some synBaseTy.Range) true arg m - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m mkUnit g m, tpenv let envInstance = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envInstance | None -> envInstance @@ -1927,7 +1927,7 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv mBinds scopem mutRecNSInfo envMutRec binds - with exn -> errorRecovery exn scopem; [], envMutRec + with exn when not exn.IsOperationCancelled -> errorRecovery exn scopem; [], envMutRec //------------------------------------------------------------------------- // Build augmentation declarations @@ -3050,7 +3050,7 @@ module EstablishTypeDefinitionCores = if not inSig then cenv.amap.assemblyLoader.RecordGeneratedTypeRoot (ProviderGeneratedType(ilOrigRootTypeRef, ilTgtRootTyRef, nested)) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn rhsType.Range #endif @@ -3145,7 +3145,7 @@ module EstablishTypeDefinitionCores = | _ -> () - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m // Third phase: check and publish the super types. Run twice, once before constraints are established @@ -3257,7 +3257,7 @@ module EstablishTypeDefinitionCores = // Publish the super type tycon.TypeContents.tcaug_super <- super - with exn -> errorRecovery exn m)) + with exn when not exn.IsOperationCancelled -> errorRecovery exn m)) /// Establish the fields, dispatch slots and union cases of a type let private TcTyconDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) envinner tpenv inSig (MutRecDefnsPhase1DataForTycon(_, synTyconRepr, _, _, _, _)) (tycon: Tycon) (attrs: Attribs) = @@ -3643,7 +3643,7 @@ module EstablishTypeDefinitionCores = | _ -> () (baseValOpt, safeInitInfo) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m None, NoSafeInitInfo @@ -3864,7 +3864,7 @@ module EstablishTypeDefinitionCores = let envForTycon = MakeInnerEnvForTyconRef envForTycon thisTyconRef false try TcTyparConstraints cenv NoNewTypars checkConstraints ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m | _ -> ()) @@ -4814,7 +4814,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE return env - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn endm return env } @@ -5182,7 +5182,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem return (defns, [], topAttrs), env, envAtEnd - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn synDecl.Range return ([], [], []), env, env } @@ -5404,7 +5404,7 @@ let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) = (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> try AddCcuToTcEnv(g, amap, scopem, env, assemblyName, ccu, autoOpens, internalsVisible) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn scopem [], env) @@ -5455,7 +5455,7 @@ let ApplyDefaults (cenv: cenv) g denvAtEnd m moduleContents extraAttribs = if not tp.IsSolved then if (tp.StaticReq <> TyparStaticReq.None) then ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig m = @@ -5475,7 +5475,7 @@ let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig | tp :: _ -> errorR (ValueRestriction(denvAtEnd, infoReader, false, v, tp, v.Range)) | _ -> () mty.ModuleAndNamespaceDefinitions |> List.iter (fun v -> check v.ModuleOrNamespaceType) - try check implFileTypePriorToSig with e -> errorRecovery e m + try check implFileTypePriorToSig with e when not e.IsOperationCancelled -> errorRecovery e m let SolveInternalUnknowns g (cenv: cenv) denvAtEnd moduleContents extraAttribs = @@ -5513,7 +5513,7 @@ let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePrior if not (SignatureConformance.Checker(g, cenv.amap, denv, remapInfo, true).CheckSignature aenv cenv.infoReader (mkLocalModuleRef implFileSpecPriorToSig) sigFileType) then // We can just raise 'ReportedError' since CheckModuleOrNamespace raises its own error raise (ReportedError None) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m (sigFileType, moduleContents) @@ -5591,7 +5591,7 @@ let CheckOneImplFile for check in cenv.css.GetPostInferenceChecksPreDefaults() do try check() - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m conditionallySuppressErrorReporting (checkForErrors()) (fun () -> @@ -5605,7 +5605,7 @@ let CheckOneImplFile implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (fun tycon -> FinalTypeDefinitionChecksAtEndOfInferenceScope (cenv.infoReader, envAtEnd.NameEnv, cenv.tcSink, true, denvAtEnd, tycon)) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m) // Check the value restriction. Only checked if there is no signature. @@ -5626,7 +5626,7 @@ let CheckOneImplFile for check in cenv.css.GetPostInferenceChecksFinal() do try check() - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m) // We ALWAYS run the PostTypeCheckSemanticChecks phase, though we if we have already encountered some @@ -5645,7 +5645,7 @@ let CheckOneImplFile implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m false, StampMap.Empty) @@ -5707,7 +5707,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 exn -> errorRecovery exn sigFile.QualifiedName.Range + with exn when not exn.IsOperationCancelled -> errorRecovery exn sigFile.QualifiedName.Range UpdatePrettyTyparNames.updateModuleOrNamespaceType sigFileType diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 496081df39d..ca1ebe08646 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -474,7 +474,7 @@ let UnifyOverallType (cenv: cenv) (env: TcEnv) m overallTy actualTy = let UnifyOverallTypeAndRecover (cenv: cenv) env m overallTy actualTy = try UnifyOverallType cenv env m overallTy actualTy - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m /// Make an environment suitable for a module or namespace. Does not create a new accumulator but uses one we already have/ @@ -4963,7 +4963,7 @@ and TcTypeOrMeasureAndRecover kindOpt (cenv: cenv) newOk checkConstraints occ iw let g = cenv.g try TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ iwsam env tpenv ty - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e ty.Range let recoveryTy = @@ -5156,7 +5156,7 @@ and TcExpr (cenv: cenv) ty (env: TcEnv) tpenv (synExpr: SynExpr) = // So be careful! try TcExprNoRecover cenv ty env tpenv synExpr - with exn -> + with exn when not exn.IsOperationCancelled -> let m = synExpr.Range // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error @@ -5185,7 +5185,7 @@ and TcExprOfUnknownTypeThen (cenv: cenv) env tpenv synExpr delayed = let expr, tpenv = try TcExprThen cenv (MustEqual exprTy) env tpenv false synExpr delayed - with exn -> + with exn when not exn.IsOperationCancelled -> let m = synExpr.Range errorRecovery exn m SolveTypeAsError env.DisplayEnv cenv.css m exprTy @@ -10962,7 +10962,7 @@ and TcAttributesWithPossibleTargetsEx canFail (cenv: cenv) env attrTgt attrEx sy attribsAndTargets, didFail || didFail2 - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e synAttrib.Range [], false) diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index 252066f8681..5af47b0073a 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/src/Compiler/Checking/CheckPatterns.fs @@ -216,7 +216,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (vFlags: TcPat and TcPatAndRecover warnOnUpper cenv (env: TcEnv) valReprInfo (vFlags: TcPatValFlags) patEnv ty (synPat: SynPat) = try TcPat warnOnUpper cenv env valReprInfo vFlags patEnv ty synPat - with e -> + with e when not e.IsOperationCancelled -> // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error let m = synPat.Range @@ -335,7 +335,7 @@ and TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m = try let c = TcConst cenv ty m env synConst (fun _ -> TPat_const (c, m)), patEnv - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m (fun _ -> TPat_error m), patEnv @@ -394,7 +394,7 @@ and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m = match names2.TryGetValue id1.idText with | true, PrelimVal1 (id=id2; prelimType=ty2) -> try UnifyTypes cenv env id2.idRange ty1 ty2 - with exn -> errorRecovery exn m + with exn when not exn.IsOperationCancelled -> errorRecovery exn m | _ -> ()) let namesR = NameMap.layer names1 names2 @@ -417,7 +417,7 @@ and TcPatTuple warnOnUpper cenv env vFlags patEnv ty isExplicitStruct args m = let argsR, acc = TcPatterns warnOnUpper cenv env vFlags patEnv argTys args let phase2 values = TPat_tuple(tupInfo, List.map (fun f -> f values) argsR, argTys, m) phase2, acc - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m let _, acc = TcPatterns warnOnUpper cenv env vFlags patEnv (NewInferenceTypes g args) args let phase2 _ = TPat_error m @@ -462,7 +462,7 @@ and TcRecordPat warnOnUpper cenv env vFlags patEnv ty fieldPats m = and TcNullPat cenv env patEnv ty m = try AddCxTypeUseSupportsNull env.DisplayEnv cenv.css m NoTrace ty - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m (fun _ -> TPat_null m), patEnv diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index 314c2d4dd12..8cc1d335f6d 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -826,7 +826,7 @@ module DispatchSlotChecking = CheckOverridesAreAllUsedOnce (denv, g, infoReader, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck) - with e -> errorRecovery e m + with e when not e.IsOperationCancelled -> errorRecovery e m // Now record the full slotsigs of the abstract members implemented by each override. // This is used to generate IL MethodImpls in the code generator. diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 292343dd223..10ce239d9a5 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -568,7 +568,7 @@ let GetTyconRefForExtensionMembers minfo (deref: Entity) amap m g = | AppTy g (tcrefOfTypeExtended, _) when not (isByrefTy g thisTy) -> Some tcrefOfTypeExtended | _ -> None Some rs - with e -> // Import of the ILType may fail, if so report the error and skip on + with e when not e.IsOperationCancelled -> // Import of the ILType may fail, if so report the error and skip on errorRecovery e m None diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 67128182ace..61ac96975f8 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2212,7 +2212,7 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = match TryChopPropertyName v.DisplayName with | Some res -> check true res | None -> () - with e -> errorRecovery e v.Range + with e when not e.IsOperationCancelled -> errorRecovery e v.Range end CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 78131431041..e58220592e6 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -1211,7 +1211,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = | Some path when FileSystem.DirectoryExistsShim(path) -> yield path | _ -> () ] - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e range0 [] @@ -1408,7 +1408,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = None else Some(m, path) - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m None diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index db6330e2bf9..458b654906d 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -680,7 +680,7 @@ type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list, tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, assemblyReference) Choice1Of2 resolutionOpt.Value - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e assemblyReference.Range Choice2Of2 assemblyReference) @@ -1913,7 +1913,7 @@ and [] TcImports for providedNamespace in providedNamespaces do loop providedNamespace - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m if startingErrorCount < DiagnosticsThreadStatics.DiagnosticsLogger.ErrorCount then diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 8c93995833e..3425b1165ee 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -2334,7 +2334,7 @@ let ApplyCommandLineArgs (tcConfigB: TcConfigBuilder, sourceFiles: string list, ParseCompilerOptions(collect, GetCoreServiceCompilerOptions tcConfigB, argv) sourceFilesAcc |> CheckAndReportSourceFileDuplicates - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e range0 sourceFiles diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index ec4018e1420..a3d0a2e617e 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -683,7 +683,7 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam input - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -756,7 +756,7 @@ let ParseOneInputStream ) = try parseInputStreamAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -772,7 +772,7 @@ let ParseOneInputSourceText ) = try parseInputSourceTextAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -781,7 +781,7 @@ let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, fileName, isLastC try checkInputFile tcConfig fileName parseInputFileAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -937,7 +937,7 @@ let ProcessMetaCommandsFromInput (* warning(Error("This meta-command has been ignored", m)) *) state - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e matchedm state @@ -1036,7 +1036,7 @@ let GetInitialTcEnv (assemblyName: string, initm: range, tcConfig: TcConfig, tcI TcOpenModuleOrNamespaceDecl TcResultsSink.NoSink tcGlobals amap initm tcEnv (checkOperatorsModule, initm) tcEnv, openDecls0 @ openDecls1 - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e initm tcEnv, openDecls0 else @@ -1378,7 +1378,7 @@ let CheckOneInput let result = (tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile) return result, tcState - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e range0 return (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState } @@ -1605,7 +1605,7 @@ let CheckOneInputWithCallback partialResult, tcState) ) - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e range0 return Finisher(node, (fun tcState -> (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState)) } diff --git a/src/Compiler/Driver/ScriptClosure.fs b/src/Compiler/Driver/ScriptClosure.fs index 83af161b353..ce2e5b4e540 100644 --- a/src/Compiler/Driver/ScriptClosure.fs +++ b/src/Compiler/Driver/ScriptClosure.fs @@ -254,7 +254,7 @@ module ScriptPreprocessClosure = let source = reader.ReadToEnd() [ ClosureSource(fileName, m, SourceText.ofString source, parseRequired) ] - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn m [] diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index ec6359a4268..bbc232d8ab3 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -4127,7 +4127,7 @@ and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = let env = BindInternalLocalVal cenv vref (mkValInfo einfo vref) env (TBind(vref, exprOptimized, spBind), einfo), env - with exn -> + with exn when not exn.IsOperationCancelled -> errorRecovery exn vref.Range raise (ReportedError (Some exn)) diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index 868868d8591..bbb819f382c 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -271,7 +271,7 @@ type DiagnosticsScope(flatErrors: bool) = // Here we only call errorRecovery to save the error message for later use by TryGetFirstErrorText. try errorRecovery e m - with _ -> + with e when not e.IsOperationCancelled -> () None match res with diff --git a/src/Compiler/TypedTree/TypeProviders.fs b/src/Compiler/TypedTree/TypeProviders.fs index dff177e296f..1b864999796 100644 --- a/src/Compiler/TypedTree/TypeProviders.fs +++ b/src/Compiler/TypedTree/TypeProviders.fs @@ -1174,7 +1174,7 @@ let TryResolveProvidedType(resolver: Tainted, m, moduleOrNamespac match ResolveProvidedType(resolver, m, moduleOrNamespace, typeName) with | Tainted.Null -> None | Tainted.NonNull ty -> Some ty - with e -> + with e when not e.IsOperationCancelled -> errorRecovery e m None diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 82cac9ef74d..858f87da68b 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -33,6 +33,13 @@ type Cancellable = | [] -> () | token :: _ -> token.ThrowIfCancellationRequested() +[] +module Cancellable = + type Exception with + member this.IsOperationCancelled = + match this with + | :? OperationCanceledException -> true + | _ -> false namespace Internal.Utilities.Library diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 122f75046aa..04328b90e46 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -9,6 +9,11 @@ type Cancellable = static member Token: CancellationToken static member CheckAndThrow: unit -> unit +[] +module Cancellable = + type Exception with + member IsOperationCancelled: bool + namespace Internal.Utilities.Library From 313558fc2dbe580f6f7ce0edeab0e9d8458f57dc Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 18 Oct 2023 16:22:43 +0200 Subject: [PATCH 04/12] Update surface area --- src/Compiler/Utilities/Cancellable.fsi | 2 +- ...FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl | 3 +++ ...harp.Compiler.Service.SurfaceArea.netstandard20.release.bsl | 3 +++ 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 04328b90e46..3c8c4e4d21c 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -10,7 +10,7 @@ type Cancellable = static member CheckAndThrow: unit -> unit [] -module Cancellable = +module internal Cancellable = type Exception with member IsOperationCancelled: bool diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl index e5d58f2ed14..191dc5030e1 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.debug.bsl @@ -1943,6 +1943,9 @@ 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: System.Threading.CancellationToken Token +FSharp.Compiler.Cancellable: System.Threading.CancellationToken get_Token() +FSharp.Compiler.Cancellable: Void CheckAndThrow() 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/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.SurfaceArea.netstandard20.release.bsl index e5d58f2ed14..191dc5030e1 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 @@ -1943,6 +1943,9 @@ 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: System.Threading.CancellationToken Token +FSharp.Compiler.Cancellable: System.Threading.CancellationToken get_Token() +FSharp.Compiler.Cancellable: Void CheckAndThrow() 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]]) From 303355689baafc07a45888bcbe214c5a0f5afdde Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 18 Oct 2023 16:24:24 +0200 Subject: [PATCH 05/12] Fantomas --- src/Compiler/Utilities/Cancellable.fs | 10 ++++++---- src/Compiler/Utilities/Cancellable.fsi | 2 +- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 858f87da68b..96bf2c48353 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -9,19 +9,20 @@ type Cancellable = [] static val mutable private tokens: CancellationToken list - static member private Tokens - with get () = + static member Tokens + with private get () = match box Cancellable.tokens with | Null -> [] | _ -> Cancellable.tokens - and set v = Cancellable.tokens <- v + and private set v = Cancellable.tokens <- v static member UsingToken(ct) = Cancellable.Tokens <- ct :: Cancellable.Tokens { new IDisposable with member this.Dispose() = - Cancellable.Tokens <- Cancellable.Tokens |> List.tail } + Cancellable.Tokens <- Cancellable.Tokens |> List.tail + } static member Token = match Cancellable.Tokens with @@ -36,6 +37,7 @@ type Cancellable = [] module Cancellable = type Exception with + member this.IsOperationCancelled = match this with | :? OperationCanceledException -> true diff --git a/src/Compiler/Utilities/Cancellable.fsi b/src/Compiler/Utilities/Cancellable.fsi index 3c8c4e4d21c..76c187fd98e 100644 --- a/src/Compiler/Utilities/Cancellable.fsi +++ b/src/Compiler/Utilities/Cancellable.fsi @@ -12,8 +12,8 @@ type Cancellable = [] module internal Cancellable = type Exception with - member IsOperationCancelled: bool + member IsOperationCancelled: bool namespace Internal.Utilities.Library From e81e4e60f903b0222b78e2deb018cca5fd48fbdf Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 18 Oct 2023 16:34:32 +0200 Subject: [PATCH 06/12] Fix build --- src/Compiler/Utilities/Cancellable.fs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 96bf2c48353..97bb7a39bf1 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -49,6 +49,10 @@ open System open System.Threading open FSharp.Compiler +#if !FSHARPCORE_USE_PACKAGE +open FSharp.Core.CompilerServices.StateMachineHelpers +#endif + [] type ValueOrCancelled<'TResult> = | Value of result: 'TResult From ad10a73d171e43873f659bc64776b7de7abc39a1 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 18 Oct 2023 16:59:32 +0200 Subject: [PATCH 07/12] Cleanup --- src/Compiler/Utilities/illib.fs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index fd3c51e5a99..efd2cae4e08 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -10,9 +10,6 @@ open System.IO open System.Threading open System.Threading.Tasks open System.Runtime.CompilerServices -#if !FSHARPCORE_USE_PACKAGE -open FSharp.Core.CompilerServices.StateMachineHelpers -#endif [] module internal PervasiveAutoOpens = From 9a3fe8c53efc47784e8a72c7d732521358644f23 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 19 Oct 2023 14:35:28 +0200 Subject: [PATCH 08/12] Use single disposable instance --- src/Compiler/Utilities/Cancellable.fs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 97bb7a39bf1..30e18d9b455 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -9,6 +9,12 @@ type Cancellable = [] static val mutable private tokens: CancellationToken list + static let disposable = + { new IDisposable with + member this.Dispose() = + Cancellable.Tokens <- Cancellable.Tokens |> List.tail + } + static member Tokens with private get () = match box Cancellable.tokens with @@ -18,11 +24,7 @@ type Cancellable = static member UsingToken(ct) = Cancellable.Tokens <- ct :: Cancellable.Tokens - - { new IDisposable with - member this.Dispose() = - Cancellable.Tokens <- Cancellable.Tokens |> List.tail - } + disposable static member Token = match Cancellable.Tokens with From 50bd3e4c6f70c5f1de9b239d82ea2b6ea30d07d6 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 19 Oct 2023 14:44:12 +0200 Subject: [PATCH 09/12] Hide recoverable exception check --- src/Compiler/Checking/CheckDeclarations.fs | 36 +++++++++---------- src/Compiler/Checking/CheckExpressions.fs | 10 +++--- src/Compiler/Checking/CheckPatterns.fs | 10 +++--- src/Compiler/Checking/MethodOverrides.fs | 2 +- src/Compiler/Checking/NameResolution.fs | 2 +- src/Compiler/Checking/PostInferenceChecks.fs | 2 +- src/Compiler/Driver/CompilerConfig.fs | 4 +-- src/Compiler/Driver/CompilerImports.fs | 4 +-- src/Compiler/Driver/CompilerOptions.fs | 2 +- src/Compiler/Driver/ParseAndCheckInputs.fs | 16 ++++----- src/Compiler/Driver/ScriptClosure.fs | 2 +- src/Compiler/Facilities/DiagnosticsLogger.fs | 5 +++ src/Compiler/Facilities/DiagnosticsLogger.fsi | 2 ++ src/Compiler/Optimize/Optimizer.fs | 2 +- src/Compiler/Symbols/FSharpDiagnostic.fs | 2 +- src/Compiler/TypedTree/TypeProviders.fs | 2 +- 16 files changed, 55 insertions(+), 48 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 48c74686630..44563d54473 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -1190,7 +1190,7 @@ module MutRecBindingChecking = let inheritsExpr, tpenv = try TcNewExpr cenv envInstance tpenv baseTy (Some synBaseTy.Range) true arg m - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m mkUnit g m, tpenv let envInstance = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envInstance | None -> envInstance @@ -1927,7 +1927,7 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv mBinds scopem mutRecNSInfo envMutRec binds - with exn when not exn.IsOperationCancelled -> errorRecovery exn scopem; [], envMutRec + with RecoverableException exn -> errorRecovery exn scopem; [], envMutRec //------------------------------------------------------------------------- // Build augmentation declarations @@ -3050,7 +3050,7 @@ module EstablishTypeDefinitionCores = if not inSig then cenv.amap.assemblyLoader.RecordGeneratedTypeRoot (ProviderGeneratedType(ilOrigRootTypeRef, ilTgtRootTyRef, nested)) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn rhsType.Range #endif @@ -3145,7 +3145,7 @@ module EstablishTypeDefinitionCores = | _ -> () - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m // Third phase: check and publish the super types. Run twice, once before constraints are established @@ -3257,7 +3257,7 @@ module EstablishTypeDefinitionCores = // Publish the super type tycon.TypeContents.tcaug_super <- super - with exn when not exn.IsOperationCancelled -> errorRecovery exn m)) + with RecoverableException exn -> errorRecovery exn m)) /// Establish the fields, dispatch slots and union cases of a type let private TcTyconDefnCore_Phase1G_EstablishRepresentation (cenv: cenv) envinner tpenv inSig (MutRecDefnsPhase1DataForTycon(_, synTyconRepr, _, _, _, _)) (tycon: Tycon) (attrs: Attribs) = @@ -3643,7 +3643,7 @@ module EstablishTypeDefinitionCores = | _ -> () (baseValOpt, safeInitInfo) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m None, NoSafeInitInfo @@ -3864,7 +3864,7 @@ module EstablishTypeDefinitionCores = let envForTycon = MakeInnerEnvForTyconRef envForTycon thisTyconRef false try TcTyparConstraints cenv NoNewTypars checkConstraints ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m | _ -> ()) @@ -4814,7 +4814,7 @@ let rec TcSignatureElementNonMutRec (cenv: cenv) parent typeNames endm (env: TcE return env - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn endm return env } @@ -5182,7 +5182,7 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem return (defns, [], topAttrs), env, envAtEnd - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn synDecl.Range return ([], [], []), env, env } @@ -5404,7 +5404,7 @@ let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) = (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> try AddCcuToTcEnv(g, amap, scopem, env, assemblyName, ccu, autoOpens, internalsVisible) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn scopem [], env) @@ -5455,7 +5455,7 @@ let ApplyDefaults (cenv: cenv) g denvAtEnd m moduleContents extraAttribs = if not tp.IsSolved then if (tp.StaticReq <> TyparStaticReq.None) then ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig m = @@ -5475,7 +5475,7 @@ let CheckValueRestriction denvAtEnd infoReader rootSigOpt implFileTypePriorToSig | tp :: _ -> errorR (ValueRestriction(denvAtEnd, infoReader, false, v, tp, v.Range)) | _ -> () mty.ModuleAndNamespaceDefinitions |> List.iter (fun v -> check v.ModuleOrNamespaceType) - try check implFileTypePriorToSig with e when not e.IsOperationCancelled -> errorRecovery e m + try check implFileTypePriorToSig with RecoverableException e -> errorRecovery e m let SolveInternalUnknowns g (cenv: cenv) denvAtEnd moduleContents extraAttribs = @@ -5513,7 +5513,7 @@ let CheckModuleSignature g (cenv: cenv) m denvAtEnd rootSigOpt implFileTypePrior if not (SignatureConformance.Checker(g, cenv.amap, denv, remapInfo, true).CheckSignature aenv cenv.infoReader (mkLocalModuleRef implFileSpecPriorToSig) sigFileType) then // We can just raise 'ReportedError' since CheckModuleOrNamespace raises its own error raise (ReportedError None) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m (sigFileType, moduleContents) @@ -5591,7 +5591,7 @@ let CheckOneImplFile for check in cenv.css.GetPostInferenceChecksPreDefaults() do try check() - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m conditionallySuppressErrorReporting (checkForErrors()) (fun () -> @@ -5605,7 +5605,7 @@ let CheckOneImplFile implFileTypePriorToSig |> IterTyconsOfModuleOrNamespaceType (fun tycon -> FinalTypeDefinitionChecksAtEndOfInferenceScope (cenv.infoReader, envAtEnd.NameEnv, cenv.tcSink, true, denvAtEnd, tycon)) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m) // Check the value restriction. Only checked if there is no signature. @@ -5626,7 +5626,7 @@ let CheckOneImplFile for check in cenv.css.GetPostInferenceChecksFinal() do try check() - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m) // We ALWAYS run the PostTypeCheckSemanticChecks phase, though we if we have already encountered some @@ -5645,7 +5645,7 @@ let CheckOneImplFile implFileTy, implFileContents, extraAttribs, isLastCompiland, isInternalTestSpanStackReferring) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m false, StampMap.Empty) @@ -5707,7 +5707,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 exn when not exn.IsOperationCancelled -> errorRecovery exn sigFile.QualifiedName.Range + with RecoverableException exn -> errorRecovery exn sigFile.QualifiedName.Range UpdatePrettyTyparNames.updateModuleOrNamespaceType sigFileType diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index ca1ebe08646..d232a04e65b 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -474,7 +474,7 @@ let UnifyOverallType (cenv: cenv) (env: TcEnv) m overallTy actualTy = let UnifyOverallTypeAndRecover (cenv: cenv) env m overallTy actualTy = try UnifyOverallType cenv env m overallTy actualTy - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m /// Make an environment suitable for a module or namespace. Does not create a new accumulator but uses one we already have/ @@ -4963,7 +4963,7 @@ and TcTypeOrMeasureAndRecover kindOpt (cenv: cenv) newOk checkConstraints occ iw let g = cenv.g try TcTypeOrMeasure kindOpt cenv newOk checkConstraints occ iwsam env tpenv ty - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e ty.Range let recoveryTy = @@ -5156,7 +5156,7 @@ and TcExpr (cenv: cenv) ty (env: TcEnv) tpenv (synExpr: SynExpr) = // So be careful! try TcExprNoRecover cenv ty env tpenv synExpr - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> let m = synExpr.Range // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error @@ -5185,7 +5185,7 @@ and TcExprOfUnknownTypeThen (cenv: cenv) env tpenv synExpr delayed = let expr, tpenv = try TcExprThen cenv (MustEqual exprTy) env tpenv false synExpr delayed - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> let m = synExpr.Range errorRecovery exn m SolveTypeAsError env.DisplayEnv cenv.css m exprTy @@ -10962,7 +10962,7 @@ and TcAttributesWithPossibleTargetsEx canFail (cenv: cenv) env attrTgt attrEx sy attribsAndTargets, didFail || didFail2 - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e synAttrib.Range [], false) diff --git a/src/Compiler/Checking/CheckPatterns.fs b/src/Compiler/Checking/CheckPatterns.fs index 5af47b0073a..5aba16020fa 100644 --- a/src/Compiler/Checking/CheckPatterns.fs +++ b/src/Compiler/Checking/CheckPatterns.fs @@ -216,7 +216,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 valReprInfo (vFlags: TcPat and TcPatAndRecover warnOnUpper cenv (env: TcEnv) valReprInfo (vFlags: TcPatValFlags) patEnv ty (synPat: SynPat) = try TcPat warnOnUpper cenv env valReprInfo vFlags patEnv ty synPat - with e when not e.IsOperationCancelled -> + with RecoverableException e -> // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error let m = synPat.Range @@ -335,7 +335,7 @@ and TcConstPat warnOnUpper cenv env vFlags patEnv ty synConst m = try let c = TcConst cenv ty m env synConst (fun _ -> TPat_const (c, m)), patEnv - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m (fun _ -> TPat_error m), patEnv @@ -394,7 +394,7 @@ and TcPatOr warnOnUpper cenv env vFlags patEnv ty pat1 pat2 m = match names2.TryGetValue id1.idText with | true, PrelimVal1 (id=id2; prelimType=ty2) -> try UnifyTypes cenv env id2.idRange ty1 ty2 - with exn when not exn.IsOperationCancelled -> errorRecovery exn m + with RecoverableException exn -> errorRecovery exn m | _ -> ()) let namesR = NameMap.layer names1 names2 @@ -417,7 +417,7 @@ and TcPatTuple warnOnUpper cenv env vFlags patEnv ty isExplicitStruct args m = let argsR, acc = TcPatterns warnOnUpper cenv env vFlags patEnv argTys args let phase2 values = TPat_tuple(tupInfo, List.map (fun f -> f values) argsR, argTys, m) phase2, acc - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m let _, acc = TcPatterns warnOnUpper cenv env vFlags patEnv (NewInferenceTypes g args) args let phase2 _ = TPat_error m @@ -462,7 +462,7 @@ and TcRecordPat warnOnUpper cenv env vFlags patEnv ty fieldPats m = and TcNullPat cenv env patEnv ty m = try AddCxTypeUseSupportsNull env.DisplayEnv cenv.css m NoTrace ty - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m (fun _ -> TPat_null m), patEnv diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs index 8cc1d335f6d..bfa11de4c02 100644 --- a/src/Compiler/Checking/MethodOverrides.fs +++ b/src/Compiler/Checking/MethodOverrides.fs @@ -826,7 +826,7 @@ module DispatchSlotChecking = CheckOverridesAreAllUsedOnce (denv, g, infoReader, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck) - with e when not e.IsOperationCancelled -> errorRecovery e m + with RecoverableException e -> errorRecovery e m // Now record the full slotsigs of the abstract members implemented by each override. // This is used to generate IL MethodImpls in the code generator. diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs index 10ce239d9a5..43783ca79a1 100644 --- a/src/Compiler/Checking/NameResolution.fs +++ b/src/Compiler/Checking/NameResolution.fs @@ -568,7 +568,7 @@ let GetTyconRefForExtensionMembers minfo (deref: Entity) amap m g = | AppTy g (tcrefOfTypeExtended, _) when not (isByrefTy g thisTy) -> Some tcrefOfTypeExtended | _ -> None Some rs - with e when not e.IsOperationCancelled -> // Import of the ILType may fail, if so report the error and skip on + with RecoverableException e -> // Import of the ILType may fail, if so report the error and skip on errorRecovery e m None diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 61ac96975f8..427854b58d5 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2212,7 +2212,7 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) = match TryChopPropertyName v.DisplayName with | Some res -> check true res | None -> () - with e when not e.IsOperationCancelled -> errorRecovery e v.Range + with RecoverableException e -> errorRecovery e v.Range end CheckBinding cenv { env with returnScope = 1 } true PermitByRefExpr.Yes bind |> ignore diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index e58220592e6..dc5ce61365a 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -1211,7 +1211,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = | Some path when FileSystem.DirectoryExistsShim(path) -> yield path | _ -> () ] - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e range0 [] @@ -1408,7 +1408,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = None else Some(m, path) - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m None diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 458b654906d..1d4b85533b7 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -680,7 +680,7 @@ type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list, tcConfig.ResolveLibWithDirectories(CcuLoadFailureAction.RaiseError, assemblyReference) Choice1Of2 resolutionOpt.Value - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e assemblyReference.Range Choice2Of2 assemblyReference) @@ -1913,7 +1913,7 @@ and [] TcImports for providedNamespace in providedNamespaces do loop providedNamespace - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m if startingErrorCount < DiagnosticsThreadStatics.DiagnosticsLogger.ErrorCount then diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 3425b1165ee..5519dee8312 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -2334,7 +2334,7 @@ let ApplyCommandLineArgs (tcConfigB: TcConfigBuilder, sourceFiles: string list, ParseCompilerOptions(collect, GetCoreServiceCompilerOptions tcConfigB, argv) sourceFilesAcc |> CheckAndReportSourceFileDuplicates - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e range0 sourceFiles diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index a3d0a2e617e..8c53f389d6f 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -683,7 +683,7 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, lexbuf, fileNam input - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -756,7 +756,7 @@ let ParseOneInputStream ) = try parseInputStreamAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked, stream) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -772,7 +772,7 @@ let ParseOneInputSourceText ) = try parseInputSourceTextAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, sourceText) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -781,7 +781,7 @@ let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, fileName, isLastC try checkInputFile tcConfig fileName parseInputFileAux (tcConfig, lexResourceManager, fileName, isLastCompiland, diagnosticsLogger, retryLocked) - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn rangeStartup EmptyParsedInput(fileName, isLastCompiland) @@ -937,7 +937,7 @@ let ProcessMetaCommandsFromInput (* warning(Error("This meta-command has been ignored", m)) *) state - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e matchedm state @@ -1036,7 +1036,7 @@ let GetInitialTcEnv (assemblyName: string, initm: range, tcConfig: TcConfig, tcI TcOpenModuleOrNamespaceDecl TcResultsSink.NoSink tcGlobals amap initm tcEnv (checkOperatorsModule, initm) tcEnv, openDecls0 @ openDecls1 - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e initm tcEnv, openDecls0 else @@ -1378,7 +1378,7 @@ let CheckOneInput let result = (tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile) return result, tcState - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e range0 return (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState } @@ -1605,7 +1605,7 @@ let CheckOneInputWithCallback partialResult, tcState) ) - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e range0 return Finisher(node, (fun tcState -> (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState)) } diff --git a/src/Compiler/Driver/ScriptClosure.fs b/src/Compiler/Driver/ScriptClosure.fs index ce2e5b4e540..629c77bed4b 100644 --- a/src/Compiler/Driver/ScriptClosure.fs +++ b/src/Compiler/Driver/ScriptClosure.fs @@ -254,7 +254,7 @@ module ScriptPreprocessClosure = let source = reader.ReadToEnd() [ ClosureSource(fileName, m, SourceText.ofString source, parseRequired) ] - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn m [] diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 342d9ce5b70..c6e34c54a95 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -2,6 +2,7 @@ module FSharp.Compiler.DiagnosticsLogger +open FSharp.Compiler open FSharp.Compiler.Diagnostics open FSharp.Compiler.Features open FSharp.Compiler.Text.Range @@ -45,6 +46,10 @@ exception ReportedError of exn option with | ReportedError (Some exn) -> msg + " Original message: " + exn.Message + ")" | _ -> msg +[] +let (|RecoverableException|_|) (exn: Exception) = + if exn.IsOperationCancelled then ValueNone else ValueSome exn + let rec findOriginalException err = match err with | ReportedError (Some err) -> err diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index e9040da36ed..04507355b9a 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -28,6 +28,8 @@ exception WrappedError of exn * range /// when a lazy thunk is re-evaluated. exception ReportedError of exn option +val (|RecoverableException|_|): exn: Exception -> Exception voption + val findOriginalException: err: exn -> exn type Suggestions = (string -> unit) -> unit diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index bbc232d8ab3..6e35a5688a2 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -4127,7 +4127,7 @@ and OptimizeBinding cenv isRec env (TBind(vref, expr, spBind)) = let env = BindInternalLocalVal cenv vref (mkValInfo einfo vref) env (TBind(vref, exprOptimized, spBind), einfo), env - with exn when not exn.IsOperationCancelled -> + with RecoverableException exn -> errorRecovery exn vref.Range raise (ReportedError (Some exn)) diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index bbb819f382c..4750f79f6ef 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -271,7 +271,7 @@ type DiagnosticsScope(flatErrors: bool) = // Here we only call errorRecovery to save the error message for later use by TryGetFirstErrorText. try errorRecovery e m - with e when not e.IsOperationCancelled -> + with RecoverableException e -> () None match res with diff --git a/src/Compiler/TypedTree/TypeProviders.fs b/src/Compiler/TypedTree/TypeProviders.fs index 1b864999796..16c69bbc71d 100644 --- a/src/Compiler/TypedTree/TypeProviders.fs +++ b/src/Compiler/TypedTree/TypeProviders.fs @@ -1174,7 +1174,7 @@ let TryResolveProvidedType(resolver: Tainted, m, moduleOrNamespac match ResolveProvidedType(resolver, m, moduleOrNamespace, typeName) with | Tainted.Null -> None | Tainted.NonNull ty -> Some ty - with e when not e.IsOperationCancelled -> + with RecoverableException e -> errorRecovery e m None From 52d392f24b1283df54d4ffa23065c4da0236d493 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 19 Oct 2023 15:13:13 +0200 Subject: [PATCH 10/12] Fix build --- src/Compiler/Symbols/FSharpDiagnostic.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Symbols/FSharpDiagnostic.fs b/src/Compiler/Symbols/FSharpDiagnostic.fs index 4750f79f6ef..2c27e7e2ff3 100644 --- a/src/Compiler/Symbols/FSharpDiagnostic.fs +++ b/src/Compiler/Symbols/FSharpDiagnostic.fs @@ -271,7 +271,7 @@ type DiagnosticsScope(flatErrors: bool) = // Here we only call errorRecovery to save the error message for later use by TryGetFirstErrorText. try errorRecovery e m - with RecoverableException e -> + with RecoverableException _ -> () None match res with From e780e5f70a872c7442bc4b594e2fbaa3f266473e Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Thu, 19 Oct 2023 16:59:54 +0200 Subject: [PATCH 11/12] Fantomas --- src/Compiler/Facilities/DiagnosticsLogger.fs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index c6e34c54a95..8f36813411f 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -48,7 +48,10 @@ exception ReportedError of exn option with [] let (|RecoverableException|_|) (exn: Exception) = - if exn.IsOperationCancelled then ValueNone else ValueSome exn + if exn.IsOperationCancelled then + ValueNone + else + ValueSome exn let rec findOriginalException err = match err with From ebdbc209dafebc6bbd904a33bf67b418ae011951 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Tue, 24 Oct 2023 17:59:18 +0200 Subject: [PATCH 12/12] Add comment --- src/Compiler/Utilities/Cancellable.fs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Compiler/Utilities/Cancellable.fs b/src/Compiler/Utilities/Cancellable.fs index 30e18d9b455..aafab9dd59a 100644 --- a/src/Compiler/Utilities/Cancellable.fs +++ b/src/Compiler/Utilities/Cancellable.fs @@ -31,6 +31,8 @@ type Cancellable = | [] -> CancellationToken.None | token :: _ -> token + /// There may be multiple tokens if `UsingToken` is called multiple times, producing scoped structure. + /// We're interested in the current, i.e. the most recent, one. static member CheckAndThrow() = match Cancellable.Tokens with | [] -> ()