Fix excessive StackGuard thread jumps (#18971)

Author: majocha

docs/large-inputs-and-stack-overflows.md

@@ -89,13 +89,12 @@ The previous example is considered incomplete, because arbitrary _combinations_
 
 ## Stack Guards
 
-The `StackGuard` type is used to count synchronous recursive processing and move to a new thread if a limit is reached. Compilation globals are re-installed. Sample:
+The `StackGuard` type is used to move to a new thread if there is no sufficient stack space for a synchronous recursive call. Compilation globals are re-installed. Sample:
 
 ```fsharp
-let TcStackGuardDepth = StackGuard.GetDepthOption "Tc"
 
 ...
-   stackGuard = StackGuard(TcMaxStackGuardDepth)
+   stackGuard = StackGuard("TcExpr")
 
 let rec ....
 
@@ -108,10 +107,17 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) =
 
 ```
 
-Note stack guarding doesn't result in a tailcall so will appear in recursive stack frames, because a counter must be decremented after the call. This is used systematically for recursive processing of:
+Note stack guarding doesn't result in a tailcall so will appear in recursive stack frames, because a counter must be decremented after the call.
 
-* SyntaxTree SynExpr
-* TypedTree Expr
+Compiling with `--times` option will show a summary if any thread switches were made due to stack guarding:
 
-We don't use it for other inputs.
+
+```
+    StackGuard jumps:
+    -----------------------------------------------------
+    | caller |        source        | jumps | min depth |
+    |--------|----------------------|-------|-----------|
+    | exprF  | TypedTreeOps.fs:7444 |    25 |      1601 |
+    -----------------------------------------------------
+```
 

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

@@ -0,0 +1,8 @@
+### Fixed
+* Fix excessive StackGuard thread jumping ([PR #18971](https://github.com/dotnet/fsharp/pull/18971))
+
+### Added
+
+### Changed
+
+### Breaking Changes

src/Compiler/AbstractIL/ilwritepdb.fs

@@ -1023,11 +1023,7 @@ let rec pushShadowedLocals (stackGuard: StackGuard) (localsToPush: PdbLocalVar[]
 //     adding the text " (shadowed)" to the names of those with name conflicts.
 let unshadowScopes rootScope =
     // Avoid stack overflow when writing linearly nested scopes
-    let UnshadowScopesStackGuardDepth =
-        GetEnvInteger "FSHARP_ILPdb_UnshadowScopes_StackGuardDepth" 100
-
-    let stackGuard =
-        StackGuard(UnshadowScopesStackGuardDepth, "ILPdbWriter.unshadowScopes")
+    let stackGuard = StackGuard("ILPdbWriter.unshadowScopes")
 
     let result, _ = pushShadowedLocals stackGuard [||] rootScope
     result

src/Compiler/Checking/CheckBasics.fs

@@ -28,12 +28,6 @@ open FSharp.Compiler.TypedTreeOps
 open FSharp.Compiler.TypeProviders
 #endif
 
-#if DEBUG
-let TcStackGuardDepth = GetEnvInteger "FSHARP_TcStackGuardDepth" 40
-#else
-let TcStackGuardDepth = GetEnvInteger "FSHARP_TcStackGuardDepth" 80
-#endif
-
 /// The ValReprInfo for a value, except the number of typars is not yet inferred
 type PrelimValReprInfo =
     | PrelimValReprInfo of
@@ -353,7 +347,7 @@ type TcFileState =
         { g = g
           amap = amap
           recUses = ValMultiMap<_>.Empty
-          stackGuard = StackGuard(TcStackGuardDepth, "TcFileState")
+          stackGuard = StackGuard("TcFileState")
           createsGeneratedProvidedTypes = false
           thisCcu = thisCcu
           isScript = isScript

src/Compiler/Checking/CheckIncrementalClasses.fs

@@ -28,8 +28,6 @@ open FSharp.Compiler.TypeHierarchy
 
 type cenv = TcFileState
 
-let TcClassRewriteStackGuardDepth = StackGuard.GetDepthOption "TcClassRewrite"
-
 exception ParameterlessStructCtor of range: range
 
 /// Represents a single group of bindings in a class with an implicit constructor
@@ -579,7 +577,7 @@ type IncrClassReprInfo =
                         PostTransform = (fun _ -> None)
                         PreInterceptBinding = None
                         RewriteQuotations = true
-                        StackGuard = StackGuard(TcClassRewriteStackGuardDepth, "FixupIncrClassExprPhase2C") } expr 
+                        StackGuard = StackGuard("FixupIncrClassExprPhase2C") } expr 
 
 type IncrClassConstructionBindingsPhase2C =
     | Phase2CBindings of IncrClassBindingGroup list

src/Compiler/Checking/FindUnsolved.fs

@@ -17,8 +17,6 @@ open FSharp.Compiler.TypeRelations
 
 type env = | NoEnv
 
-let FindUnsolvedStackGuardDepth = StackGuard.GetDepthOption "FindUnsolved"
-
 /// The environment and collector
 type cenv =
     { g: TcGlobals
@@ -318,7 +316,7 @@ let UnsolvedTyparsOfModuleDef g amap denv mdef extraAttribs =
           amap=amap
           denv=denv
           unsolved = []
-          stackGuard = StackGuard(FindUnsolvedStackGuardDepth, "UnsolvedTyparsOfModuleDef") }
+          stackGuard = StackGuard("UnsolvedTyparsOfModuleDef") }
     accModuleOrNamespaceDef cenv NoEnv mdef
     accAttribs cenv NoEnv extraAttribs
     List.rev cenv.unsolved

src/Compiler/Checking/PostInferenceChecks.fs

@@ -57,8 +57,6 @@ open Import
 //     b) a lambda expression - rejected.
 //     c) none of the above - rejected as when checking outmost expressions.
 
-let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_PostInferenceChecks" 50
-
 //--------------------------------------------------------------------------
 // check environment
 //--------------------------------------------------------------------------
@@ -2691,7 +2689,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v
           reportErrors = reportErrors
           boundVals = Dictionary<_, _>(100, HashIdentity.Structural)
           limitVals = Dictionary<_, _>(100, HashIdentity.Structural)
-          stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile")
+          stackGuard = StackGuard("CheckImplFile")
           potentialUnboundUsesOfVals = Map.empty
           anonRecdTypes = StampMap.Empty
           usesQuotations = false

src/Compiler/Checking/TailCallChecks.fs

@@ -16,8 +16,6 @@ open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
 open FSharp.Compiler.TypeRelations
 
-let PostInferenceChecksStackGuardDepth = GetEnvInteger "FSHARP_TailCallChecks" 50
-
 [<return: Struct>]
 let (|ValUseAtApp|_|) e =
     match e with
@@ -887,7 +885,7 @@ let CheckImplFile (g: TcGlobals, amap, reportErrors, implFileContents) =
         let cenv =
             {
                 g = g
-                stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile")
+                stackGuard = StackGuard("CheckImplFile")
                 amap = amap
                 mustTailCall = Zset.empty valOrder
                 hasPinnedLocals = false

src/Compiler/CodeGen/IlxGen.fs

@@ -45,10 +45,7 @@ open FSharp.Compiler.TypedTreeOps.DebugPrint
 open FSharp.Compiler.TypeHierarchy
 open FSharp.Compiler.TypeRelations
 
-let IlxGenStackGuardDepth = StackGuard.GetDepthOption "IlxGen"
-
-let getEmptyStackGuard () =
-    StackGuard(IlxGenStackGuardDepth, "IlxAssemblyGenerator")
+let getEmptyStackGuard () = StackGuard("IlxAssemblyGenerator")
 
 let IsNonErasedTypar (tp: Typar) = not tp.IsErased
 

src/Compiler/Facilities/DiagnosticsLogger.fs

@@ -879,17 +879,18 @@ module StackGuardMetrics =
             description = "Tracks the number of times the stack guard has jumped to a new thread"
         )
 
-    let countJump memberName location =
+    let countJump memberName location depth =
         let tags =
             let mutable tags = TagList()
             tags.Add(Activity.Tags.callerMemberName, memberName)
             tags.Add("source", location)
+            tags.Add("depth", depth)
             tags
 
         jumpCounter.Add(1L, &tags)
 
     // Used by the self-listener.
-    let jumpsByFunctionName = ConcurrentDictionary<_, int64 ref>()
+    let dataByFunctionName = ConcurrentDictionary<_, int64 ref * int ref>()
 
     let Listen () =
         let listener = new Metrics.MeterListener()
@@ -899,20 +900,26 @@ module StackGuardMetrics =
         listener.SetMeasurementEventCallback(fun _ v tags _ ->
             let memberName = nonNull tags[0].Value :?> string
             let source = nonNull tags[1].Value :?> string
-            let counter = jumpsByFunctionName.GetOrAdd((memberName, source), fun _ -> ref 0L)
-            Interlocked.Add(counter, v) |> ignore)
+            let depth = nonNull tags[2].Value :?> int
+
+            let counter, minDepth =
+                dataByFunctionName.GetOrAdd((memberName, source), fun _ -> ref 0L, ref Int32.MaxValue)
+
+            counter.Value <- counter.Value + v
+            minDepth.Value <- min depth minDepth.Value)
 
         listener.Start()
         listener :> IDisposable
 
     let StatsToString () =
-        let headers = [ "caller"; "source"; "jumps" ]
+        let headers = [ "caller"; "source"; "jumps"; "min depth" ]
 
         let data =
             [
-                for kvp in jumpsByFunctionName do
+                for kvp in dataByFunctionName do
                     let (memberName, source) = kvp.Key
-                    [ memberName; source; string kvp.Value.Value ]
+                    let jumps, depth = kvp.Value
+                    [ memberName; source; string jumps.Value; string depth.Value ]
             ]
 
         if List.isEmpty data then
@@ -930,9 +937,23 @@ module StackGuardMetrics =
         }
 
 /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached
-type StackGuard(maxDepth: int, name: string) =
+type StackGuard(name: string) =
+
+    let depth = new ThreadLocal<int>()
 
-    let mutable depth = 1
+    static member inline IsStackSufficient() =
+
+        // We single out netstandard2.0 because it lacks the non-throwing TryEnsureSufficientExecutionStack
+        // TODO: Get rid of this throwing version as soon as we can.
+#if NETSTANDARD2_0
+        try
+            RuntimeHelpers.EnsureSufficientExecutionStack()
+            true
+        with :? InsufficientExecutionStackException ->
+            false
+#else
+        RuntimeHelpers.TryEnsureSufficientExecutionStack()
+#endif
 
     [<DebuggerHidden; DebuggerStepThrough>]
     member _.Guard
@@ -943,40 +964,30 @@ type StackGuard(maxDepth: int, name: string) =
             [<CallerLineNumber; Optional; DefaultParameterValue(0)>] line: int
         ) =
 
-        depth <- depth + 1
+        depth.Value <- depth.Value + 1
 
         try
-            if depth % maxDepth = 0 then
-
+            if StackGuard.IsStackSufficient() then
+                f ()
+            else
                 let fileName = System.IO.Path.GetFileName(path)
+                let depthWhenJump = depth.Value
 
-                StackGuardMetrics.countJump memberName $"{fileName}:{line}"
+                StackGuardMetrics.countJump memberName $"{fileName}:{line}" depthWhenJump
 
                 async {
                     do! Async.SwitchToNewThread()
-                    Thread.CurrentThread.Name <- $"F# Extra Compilation Thread for {name} (depth {depth})"
+                    Thread.CurrentThread.Name <- $"F# Extra Compilation Thread for {name} (depth {depthWhenJump})"
                     return f ()
                 }
                 |> Async.RunImmediate
-            else
-                f ()
         finally
-            depth <- depth - 1
+            depth.Value <- depth.Value - 1
 
     [<DebuggerHidden; DebuggerStepThrough>]
     member x.GuardCancellable(original: Cancellable<'T>) =
         Cancellable(fun ct -> x.Guard(fun () -> Cancellable.run ct original))
 
-    static member val DefaultDepth =
-#if DEBUG
-        GetEnvInteger "FSHARP_DefaultStackGuardDepth" 50
-#else
-        GetEnvInteger "FSHARP_DefaultStackGuardDepth" 100
-#endif
-
-    static member GetDepthOption(name: string) =
-        GetEnvInteger ("FSHARP_" + name + "StackGuardDepth") StackGuard.DefaultDepth
-
 // UseMultipleDiagnosticLoggers in ParseAndCheckProject.fs provides similar functionality.
 // We should probably adapt and reuse that code.
 module MultipleDiagnosticsLoggers =