Fix StackOverflow in non-recursive bindings checker

docs/release-notes/.FSharp.Compiler.Service/8.0.300.md

@@ -24,7 +24,7 @@
 * Enforce AttributeTargets on enums ([PR #16887](https://github.com/dotnet/fsharp/pull/16887))
 * Completion: fix for unfinished record field decl ([PR #16893](https://github.com/dotnet/fsharp/pull/16893))
 * Enforce AttributeTargets on delegates ([PR #16891](https://github.com/dotnet/fsharp/pull/16891))
-
+* Fix StackOverflow when checking non-recursive bindings in module or namespace in `fscAnyCpu`/`fsiAnyCpu`. ([PR #16908](https://github.com/dotnet/fsharp/pull/16908))
 
 ### Added
 

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
@@ -5330,22 +5331,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 [<TailCall>] 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) =
@@ -5470,20 +5478,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.

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,25 @@ type StackGuard(maxDepth: int, name: string) =
     let mutable depth = 1
 
     [<DebuggerHidden; DebuggerStepThrough>]
-    member _.Guard(f) =
+    member _.Guard
+        (
+            f,
+            [<CallerMemberName; Optional; DefaultParameterValue("")>] memberName: string,
+            [<CallerFilePath; Optional; DefaultParameterValue("")>] path: string,
+            [<CallerLineNumber; Optional; DefaultParameterValue(0)>] 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

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
 [<RequireQualifiedAccess>]
@@ -448,7 +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) -> 'T
+    member Guard:
+        f: (unit -> 'T) *
+        [<CallerMemberName; Optional; DefaultParameterValue("")>] memberName: string *
+        [<CallerFilePath; Optional; DefaultParameterValue("")>] path: string *
+        [<CallerLineNumber; Optional; DefaultParameterValue(0)>] line: int ->
+            'T
 
     static member GetDepthOption: string -> int
 

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 =

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