Fix excessive StackGuard thread jumps

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,9 @@ 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 mutable depth = 1
+    let depth = new ThreadLocal<int>()
 
     [<DebuggerHidden; DebuggerStepThrough>]
     member _.Guard
@@ -943,40 +950,33 @@ 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
+            try
+                RuntimeHelpers.EnsureSufficientExecutionStack()
+                f ()
+            with :? InsufficientExecutionStackException ->
+                // If we hit the execution stack limit, jump to a new thread regardless of depth.
 
                 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 =

src/Compiler/Facilities/DiagnosticsLogger.fsi

@@ -465,7 +465,7 @@ module internal StackGuardMetrics =
     val CaptureStatsAndWriteToConsole: unit -> IDisposable
 
 type StackGuard =
-    new: maxDepth: int * name: string -> StackGuard
+    new: name: string -> StackGuard
 
     /// Execute the new function, on a new thread if necessary
     member Guard:
@@ -477,8 +477,6 @@ type StackGuard =
 
     member GuardCancellable: Internal.Utilities.Library.Cancellable<'T> -> Internal.Utilities.Library.Cancellable<'T>
 
-    static member GetDepthOption: string -> int
-
 /// This represents the global state established as each task function runs as part of the build.
 ///
 /// Use to reset error and warning handlers.

src/Compiler/Optimize/DetupleArgs.fs

@@ -14,8 +14,6 @@ open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
 open FSharp.Compiler.Xml
 
-let DetupleRewriteStackGuardDepth = StackGuard.GetDepthOption "DetupleRewrite"
-
 // This pass has one aim.
 // - to eliminate tuples allocated at call sites (due to uncurried style)
 //
@@ -943,7 +941,7 @@ let passImplFile penv assembly =
           PreInterceptBinding = None
           PostTransform = postTransformExpr penv
           RewriteQuotations = false
-          StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") }
+          StackGuard = StackGuard("RewriteImplFile") }
 
     assembly |> RewriteImplFile rwenv
 

src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs

@@ -22,8 +22,6 @@ open FSharp.Compiler.TcGlobals
 
 let verboseTLR = false
 
-let InnerLambdasToTopLevelFunctionsStackGuardDepth = StackGuard.GetDepthOption "InnerLambdasToTopLevelFunctions"
-
 //-------------------------------------------------------------------------
 // library helpers
 //-------------------------------------------------------------------------
@@ -1372,7 +1370,7 @@ let MakeTopLevelRepresentationDecisions ccu g expr =
                 recShortCallS = recShortCallS
                 envPackM = envPackM
                 fHatM = fHatM
-                stackGuard = StackGuard(InnerLambdasToTopLevelFunctionsStackGuardDepth, "InnerLambdasToTopLevelFunctionsStackGuardDepth") }
+                stackGuard = StackGuard("InnerLambdasToTopLevelFunctionsStackGuardDepth") }
           let z = Pass4_RewriteAssembly.rewriteState0
           Pass4_RewriteAssembly.TransImplFile penv z expr
 

src/Compiler/Optimize/LowerCalls.fs

@@ -7,8 +7,6 @@ open FSharp.Compiler.DiagnosticsLogger
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeOps
 
-let LowerCallsRewriteStackGuardDepth = StackGuard.GetDepthOption "LowerCallsRewrite"
-
 //----------------------------------------------------------------------------
 // Expansion of calls to methods with statically known arity
 
@@ -49,5 +47,5 @@ let LowerImplFile g assembly =
           PreInterceptBinding=None
           PostTransform= (fun _ -> None)
           RewriteQuotations=false
-          StackGuard = StackGuard(LowerCallsRewriteStackGuardDepth, "LowerCallsRewriteStackGuardDepth") }
+          StackGuard = StackGuard("LowerCallsRewriteStackGuardDepth") }
     assembly |> RewriteImplFile rwenv

src/Compiler/Optimize/LowerLocalMutables.fs

@@ -15,8 +15,6 @@ open FSharp.Compiler.TypeRelations
 //----------------------------------------------------------------------------
 // Decide the set of mutable locals to promote to heap-allocated reference cells
 
-let AutoboxRewriteStackGuardDepth = StackGuard.GetDepthOption "AutoboxRewrite"
-
 type cenv = 
     { g: TcGlobals
       amap: Import.ImportMap }
@@ -196,6 +194,6 @@ let TransformImplFile g amap implFile =
                 PreInterceptBinding = Some(TransformBinding g heapValMap)
                 PostTransform = (fun _ -> None)
                 RewriteQuotations = true
-                StackGuard = StackGuard(AutoboxRewriteStackGuardDepth, "AutoboxRewriteStackGuardDepth") } 
+                StackGuard = StackGuard("AutoboxRewriteStackGuardDepth") } 
 
 

src/Compiler/Optimize/LowerStateMachines.fs

@@ -14,8 +14,6 @@ open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
 
-let LowerStateMachineStackGuardDepth = StackGuard.GetDepthOption "LowerStateMachines"
-
 type StateMachineConversionFirstPhaseResult =
    {
      /// Represents the expanded expression prior to decisions about labels
@@ -356,7 +354,7 @@ type LowerStateMachine(g: TcGlobals) =
           PostTransform = (fun _ -> None)
           PreInterceptBinding = None
           RewriteQuotations=true 
-          StackGuard = StackGuard(LowerStateMachineStackGuardDepth, "LowerStateMachineStackGuardDepth") }
+          StackGuard = StackGuard("LowerStateMachineStackGuardDepth") }
 
     let ConvertStateMachineLeafExpression (env: env) expr = 
         if sm_verbose then printfn "ConvertStateMachineLeafExpression for %A..." expr