From e547bf6e0c9fd544cead82e8289f2326f1647de4 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 20 Mar 2024 15:29:12 +0100 Subject: [PATCH 1/4] Fix StackOverflow in non-recursive bindings checker --- src/Compiler/Checking/CheckDeclarations.fs | 67 +++++++++++-------- src/Compiler/Facilities/DiagnosticsLogger.fs | 16 ++++- src/Compiler/Facilities/DiagnosticsLogger.fsi | 7 +- src/Compiler/Utilities/Activity.fs | 12 ++++ src/Compiler/Utilities/Activity.fsi | 6 ++ 5 files changed, 79 insertions(+), 29 deletions(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 501d7927ec..af8f802e1e 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -4,6 +4,7 @@ module internal FSharp.Compiler.CheckDeclarations open System open System.Collections.Generic +open System.Threading open FSharp.Compiler.Diagnostics open Internal.Utilities.Collections @@ -5327,22 +5328,29 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem } /// The non-mutually recursive case for a sequence of declarations -and TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) = - cancellable { - match moreDefs with - | firstDef :: otherDefs -> - // Lookahead one to find out the scope of the next declaration. - let scopem = - if isNil otherDefs then unionRanges firstDef.Range endm - else unionRanges (List.head otherDefs).Range endm +and [] TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) (ct: CancellationToken) = + + if ct.IsCancellationRequested then + ValueOrCancelled.Cancelled (OperationCanceledException()) + else + match moreDefs with + | [] -> + ValueOrCancelled.Value (List.rev defsSoFar, envAtEnd) + | firstDef :: otherDefs -> + // Lookahead one to find out the scope of the next declaration. + let scopem = + if isNil otherDefs then + unionRanges firstDef.Range endm + else + unionRanges (List.head otherDefs).Range endm - let! firstDef, env, envAtEnd = TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef + let result = Cancellable.run ct (TcModuleOrNamespaceElementNonMutRec cenv parent typeNames scopem env firstDef) - // tail recursive - return! TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ( (firstDef :: defsSoFar), env, envAtEnd) otherDefs - | [] -> - return List.rev defsSoFar, envAtEnd - } + 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 /// The mutually recursive case for a sequence of declarations (and nested modules) and TcModuleOrNamespaceElementsMutRec (cenv: cenv) parent typeNames m envInitial mutRecNSInfo (defs: SynModuleDecl list) = @@ -5467,20 +5475,25 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 escapeCheck() return (moduleContents, topAttrsNew, envAtEnd) - | None -> - - 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 + | None -> + let! ct = Cancellable.token () + let result = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls ct + //let! compiledDefs, envAtEnd = 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) + } - // Collect up the attributes that are global to the file - let topAttrsNew = compiledDefs |> List.collect p33 - return (moduleContents, topAttrsNew, envAtEnd) - } - //-------------------------------------------------------------------------- // CheckOneImplFile - Typecheck all the namespace fragments in a file. diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 75dfaaef39..8ef1ab0f0f 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -11,6 +11,8 @@ open System open System.Diagnostics open System.Reflection open System.Threading +open System.Runtime.CompilerServices +open System.Runtime.InteropServices open Internal.Utilities.Library open Internal.Utilities.Library.Extras open System.Collections.Concurrent @@ -853,7 +855,19 @@ type StackGuard(maxDepth: int, name: string) = let mutable depth = 1 [] - member _.Guard(f) = + member _.Guard(f, [] memberName: string, + [] path: string, + [] line: int) = + use _ = + Activity.start "DiagnosticsLogger.StackGuard.Guard" + [| + Activity.Tags.stackGuardName, name + Activity.Tags.stackGuardCurrentDepth, string depth + Activity.Tags.stackGuardMaxDepth, string maxDepth + Activity.Tags.callerMemberName, memberName + Activity.Tags.callerFilePath, path + Activity.Tags.callerLineNumber, string line + |] depth <- depth + 1 try diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index bcbdd197b7..94c5d6ca66 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -6,6 +6,8 @@ open System open FSharp.Compiler.Diagnostics open FSharp.Compiler.Features open FSharp.Compiler.Text +open System.Runtime.CompilerServices +open System.Runtime.InteropServices /// Represents the style being used to format errors [] @@ -448,7 +450,10 @@ type StackGuard = new: maxDepth: int * name: string -> StackGuard /// Execute the new function, on a new thread if necessary - member Guard: f: (unit -> 'T) -> 'T + member Guard: f: (unit -> 'T) + * [] memberName: string + * [] path: string + * [] line: int -> 'T static member GetDepthOption: string -> int diff --git a/src/Compiler/Utilities/Activity.fs b/src/Compiler/Utilities/Activity.fs index 5f1d9c3354..ebc0863302 100644 --- a/src/Compiler/Utilities/Activity.fs +++ b/src/Compiler/Utilities/Activity.fs @@ -34,6 +34,12 @@ module internal Activity = let outputDllFile = "outputDllFile" let buildPhase = "buildPhase" let version = "version" + let stackGuardName = "stackGuardName" + let stackGuardCurrentDepth = "stackGuardCurrentDepth" + let stackGuardMaxDepth = "stackGuardMaxDepth" + let callerMemberName = "callerMemberName" + let callerFilePath = "callerFilePath" + let callerLineNumber = "callerLineNumber" let AllKnownTags = [| @@ -50,6 +56,12 @@ module internal Activity = gc2 outputDllFile buildPhase + stackGuardName + stackGuardCurrentDepth + stackGuardMaxDepth + callerMemberName + callerFilePath + callerLineNumber |] module Events = diff --git a/src/Compiler/Utilities/Activity.fsi b/src/Compiler/Utilities/Activity.fsi index afce0f3b55..ec6a9fbf6f 100644 --- a/src/Compiler/Utilities/Activity.fsi +++ b/src/Compiler/Utilities/Activity.fsi @@ -29,6 +29,12 @@ module internal Activity = val cache: string val buildPhase: string val version: string + val stackGuardName: string + val stackGuardCurrentDepth: string + val stackGuardMaxDepth: string + val callerMemberName: string + val callerFilePath: string + val callerLineNumber: string module Events = val cacheHit: string From 2d5e4395b301848ee6ab9438d3062138d96088b8 Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 20 Mar 2024 15:36:08 +0100 Subject: [PATCH 2/4] Release notes --- docs/release-notes/.FSharp.Compiler.Service/8.0.300.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md b/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md index d5dc02e051..07e2097934 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md +++ b/docs/release-notes/.FSharp.Compiler.Service/8.0.300.md @@ -21,6 +21,7 @@ * Parser: fix pattern range for idents with trivia ([PR #16824](https://github.com/dotnet/fsharp/pull/16824)) * Fix broken code completion after a record type declaration ([PR #16813](https://github.com/dotnet/fsharp/pull/16813)) * Enforce AttributeTargets on enums ([PR #16887](https://github.com/dotnet/fsharp/pull/16887)) +* Fix StackOverflow when checking non-recursive bindings in module or namespace in `fscAnyCpu`/`fsiAnyCpu`. ([PR #16908](https://github.com/dotnet/fsharp/pull/16908)) ### Added From e71882ab45d480d63933d137004d4d7148948def Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Wed, 20 Mar 2024 14:41:07 +0000 Subject: [PATCH 3/4] Automated command ran: fantomas Co-authored-by: vzarytovskii <1260985+vzarytovskii@users.noreply.github.com> --- src/Compiler/Facilities/DiagnosticsLogger.fs | 14 ++++++++++---- src/Compiler/Facilities/DiagnosticsLogger.fsi | 10 ++++++---- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index 8ef1ab0f0f..d93a3a60b6 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -855,11 +855,16 @@ type StackGuard(maxDepth: int, name: string) = let mutable depth = 1 [] - member _.Guard(f, [] memberName: string, - [] path: string, - [] line: int) = + member _.Guard + ( + f, + [] memberName: string, + [] path: string, + [] line: int + ) = use _ = - Activity.start "DiagnosticsLogger.StackGuard.Guard" + Activity.start + "DiagnosticsLogger.StackGuard.Guard" [| Activity.Tags.stackGuardName, name Activity.Tags.stackGuardCurrentDepth, string depth @@ -868,6 +873,7 @@ type StackGuard(maxDepth: int, name: string) = Activity.Tags.callerFilePath, path Activity.Tags.callerLineNumber, string line |] + depth <- depth + 1 try diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index 94c5d6ca66..ec2d37bc04 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -450,10 +450,12 @@ type StackGuard = new: maxDepth: int * name: string -> StackGuard /// Execute the new function, on a new thread if necessary - member Guard: f: (unit -> 'T) - * [] memberName: string - * [] path: string - * [] line: int -> 'T + member Guard: + f: (unit -> 'T) * + [] memberName: string * + [] path: string * + [] line: int -> + 'T static member GetDepthOption: string -> int From 40a1ed305950fc970923422ba2bb0c68922b7b5b Mon Sep 17 00:00:00 2001 From: Vlad Zarytovskii Date: Wed, 20 Mar 2024 17:20:26 +0100 Subject: [PATCH 4/4] Update src/Compiler/Checking/CheckDeclarations.fs Remove commented-out code --- src/Compiler/Checking/CheckDeclarations.fs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index ad2f995dad..f1037f7f1b 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5481,7 +5481,6 @@ and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo openDecls0 | None -> let! ct = Cancellable.token () let result = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls ct - //let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent typeNames endm ([], env, env) synModuleDecls ct match result with | ValueOrCancelled.Value(compiledDefs, envAtEnd) ->