12322: Fix deep recursive expression processing

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

@@ -21,6 +21,13 @@ The compiler performs constant folding for large constants so there are no costs
 
 Many sources of `StackOverflow` exceptions prior to F# 4.7 when processing these kinds of constructs were resolved by processing them on the heap via continuation passing techniques. This avoids filling data on the stack and appears to have negligible effects on overall throughout or memory usage of the compiler.
 
+There are two techniques to deal with this
+
+1. Linearizing processing of specific input shapes, keeping stacks small
+2. Using stack guards to simply temporarily move to a new thread when a certain threshold is reached.
+
+## Linearizing processing if certain inputs
+
 Aside from array expressions, most of the previously-listed inputs are called "linear" expressions. This means that there is a single linear hole in the shape of expressions. For example:
 
 * `expr :: HOLE` (list expressions or other right-linear constructions)
@@ -80,3 +87,31 @@ Some common aspects of this style of programming are:
 
 The previous example is considered incomplete, because arbitrary _combinations_ of `let` and sequential expressions aren't going to be dealt with in a tail-recursive way. The compiler generally tries to do these combinations as well.
 
+## 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:
+
+```fsharp
+let TcStackGuardDepth = StackGuard.GetDepthOption "Tc"
+
+...
+   stackGuard = StackGuard(TcMaxStackGuardDepth)
+
+let rec ....
+
+and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) =
+
+    // Guard the stack for deeply nested expressions
+    cenv.stackGuard.Guard <| fun () ->
+
+    ...
+
+```
+
+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:
+
+* SyntaxTree SynExpr
+* TypedTree Expr
+
+We don't use it for other inputs.
+

src/fsharp/BuildGraph.fs

@@ -10,22 +10,6 @@ open System.Globalization
 open FSharp.Compiler.ErrorLogger
 open Internal.Utilities.Library
 
-/// This represents the thread-local state established as each task function runs as part of the build.
-///
-/// Use to reset error and warning handlers.
-type CompilationGlobalsScope(errorLogger: ErrorLogger, phase: BuildPhase) = 
-    let unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger)
-    let unwindBP = PushThreadBuildPhaseUntilUnwind phase
-
-    member _.ErrorLogger = errorLogger
-    member _.Phase = phase
-
-    // Return the disposable object that cleans up
-    interface IDisposable with
-        member d.Dispose() =
-            unwindBP.Dispose()         
-            unwindEL.Dispose()
-
 [<NoEquality;NoComparison>]
 type NodeCode<'T> = Node of Async<'T>
 
@@ -89,7 +73,7 @@ type NodeCodeBuilder() =
         Node(
             async {
                 CompileThreadStatic.ErrorLogger <- value.ErrorLogger
-                CompileThreadStatic.BuildPhase <- value.Phase
+                CompileThreadStatic.BuildPhase <- value.BuildPhase
                 try
                     return! binder value |> Async.AwaitNodeCode
                 finally

src/fsharp/BuildGraph.fsi

@@ -8,13 +8,6 @@ open System.Threading.Tasks
 open FSharp.Compiler.ErrorLogger
 open Internal.Utilities.Library
 
-/// This represents the global state established as each task function runs as part of the build.
-///
-/// Use to reset error and warning handlers.
-type CompilationGlobalsScope =
-    new : ErrorLogger * BuildPhase -> CompilationGlobalsScope
-    interface IDisposable
-
 /// Represents code that can be run as part of the build graph.
 ///
 /// This is essentially cancellable async code where the only asynchronous waits are on nodes.

src/fsharp/CheckComputationExpressions.fs

@@ -760,6 +760,8 @@ let TcComputationExpression cenv env (overallTy: OverallTy) tpenv (mWhole, inter
     // translatedCtxt - represents the translation of the context in which the computation expression 'comp' occurs, up to a
     //                  hole to be filled by (part of) the results of translating 'comp'.
     let rec tryTrans firstTry q varSpace comp translatedCtxt =
+        // Guard the stack for deeply nested computation expressions
+        cenv.stackGuard.Guard <| fun () ->
 
         match comp with 
 

src/fsharp/CheckDeclarations.fs

@@ -42,6 +42,8 @@ open FSharp.Compiler.ExtensionTyping
 
 type cenv = TcFileState
 
+let TcClassRewriteStackGuardDepth = StackGuard.GetDepthOption "TcClassRewrite"
+
 //-------------------------------------------------------------------------
 // Mutually recursive shapes
 //------------------------------------------------------------------------- 
@@ -1144,8 +1146,8 @@ module IncrClassChecking =
             RewriteExpr { PreIntercept = Some FixupExprNode 
                           PostTransform = (fun _ -> None)
                           PreInterceptBinding = None
-                          IsUnderQuotations=true } expr 
-
+                          RewriteQuotations = true
+                          StackGuard = StackGuard(TcClassRewriteStackGuardDepth) } expr 
 
     type IncrClassConstructionBindingsPhase2C =
       | Phase2CBindings of IncrClassBindingGroup list

src/fsharp/CheckExpressions.fs

@@ -51,6 +51,12 @@ let mkNilListPat (g: TcGlobals) m ty = TPat_unioncase(g.nil_ucref, [ty], [], m)
 
 let mkConsListPat (g: TcGlobals) ty ph pt = TPat_unioncase(g.cons_ucref, [ty], [ph;pt], unionRanges ph.Range pt.Range)
 
+#if DEBUG
+let TcStackGuardDepth = GetEnvInteger "FSHARP_TcStackGuardDepth" 40
+#else
+let TcStackGuardDepth = GetEnvInteger "FSHARP_TcStackGuardDepth" 80
+#endif
+
 //-------------------------------------------------------------------------
 // Errors.
 //-------------------------------------------------------------------------
@@ -358,6 +364,9 @@ type TcFileState =
       /// we infer type parameters
       mutable recUses: ValMultiMap<Expr ref * range * bool>
 
+      /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached
+      stackGuard: StackGuard
+
       /// Set to true if this file causes the creation of generated provided types.
       mutable createsGeneratedProvidedTypes: bool
 
@@ -421,6 +430,7 @@ type TcFileState =
         { g = g
           amap = amap
           recUses = ValMultiMap<_>.Empty
+          stackGuard = StackGuard(TcStackGuardDepth)
           createsGeneratedProvidedTypes = false
           topCcu = topCcu
           isScript = isScript
@@ -5359,7 +5369,11 @@ and TcExprFlex2 cenv desiredTy env isMethodArg tpenv synExpr =
     TcExpr cenv (MustConvertTo (isMethodArg, desiredTy)) env tpenv synExpr
 
 and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) =
-    // Start an error recovery handler
+
+    // Guard the stack for deeply nested expressions
+    cenv.stackGuard.Guard <| fun () ->
+
+    // Start an error recovery handler, and check for stack recursion depth, moving to a new stack if necessary.
     // Note the try/with can lead to tail-recursion problems for iterated constructs, e.g. let... in...
     // So be careful!
     try

src/fsharp/CheckExpressions.fsi

@@ -10,6 +10,7 @@ open FSharp.Compiler.AbstractIL.IL
 open FSharp.Compiler.AccessibilityLogic
 open FSharp.Compiler.CompilerGlobalState
 open FSharp.Compiler.ConstraintSolver
+open FSharp.Compiler.ErrorLogger
 open FSharp.Compiler.Import
 open FSharp.Compiler.InfoReader
 open FSharp.Compiler.Infos
@@ -180,6 +181,9 @@ type TcFileState =
       /// we infer type parameters 
       mutable recUses: ValMultiMap<Expr ref * range * bool>
 
+      /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached
+      stackGuard: StackGuard
+
       /// Set to true if this file causes the creation of generated provided types.
       mutable createsGeneratedProvidedTypes: bool
 

src/fsharp/CompilerDiagnostics.fs

@@ -1655,7 +1655,7 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa
           os.Append(TargetInvocationExceptionWrapperE().Format e.Message) |> ignore
 #if DEBUG
           Printf.bprintf os "\nStack Trace\n%s\n" (e.ToString())
-          if !showAssertForUnexpectedException then
+          if showAssertForUnexpectedException.Value then
               Debug.Assert(false, sprintf "Unknown exception seen in compiler: %s" (e.ToString()))
 #endif
 

src/fsharp/DetupleArgs.fs

@@ -5,13 +5,16 @@ module internal FSharp.Compiler.Detuple
 open Internal.Utilities.Collections
 open Internal.Utilities.Library 
 open Internal.Utilities.Library.Extras
-open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.ErrorLogger
 open FSharp.Compiler.Syntax
+open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.Text
-open FSharp.Compiler.Xml
 open FSharp.Compiler.TypedTree
 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)
@@ -174,16 +177,23 @@ module GlobalUsageAnalysis =
     ///      where first accessor in list applies first to the v/app.
     ///   (b) log it's binding site representation.
     type Results =
-       { ///  v -> context / APP inst args 
+       {
+         ///  v -> context / APP inst args 
          Uses     : Zmap<Val, (accessor list * TType list * Expr list) list>
+
          /// v -> binding repr 
          Defns     : Zmap<Val, Expr>                                        
+
          /// bound in a decision tree? 
-         DecisionTreeBindings    : Zset<Val>                                    
+         DecisionTreeBindings: Zset<Val>                                    
+
          ///  v -> v list * recursive? -- the others in the mutual binding 
-         RecursiveBindings  : Zmap<Val, bool * Vals>
-         TopLevelBindings : Zset<Val>
-         IterationIsAtTopLevel      : bool }
+         RecursiveBindings: Zmap<Val, bool * Vals>
+
+         TopLevelBindings: Zset<Val>
+
+         IterationIsAtTopLevel: bool
+       }
 
     let z0 =
        { Uses     = Zmap.empty valOrder
@@ -841,10 +851,13 @@ let postTransformExpr (penv: penv) expr =
     | _ -> None
 
 let passImplFile penv assembly = 
-    assembly |> RewriteImplFile { PreIntercept =None
-                                  PreInterceptBinding=None
-                                  PostTransform= postTransformExpr penv
-                                  IsUnderQuotations=false } 
+    let rwenv =
+        { PreIntercept = None
+          PreInterceptBinding = None
+          PostTransform = postTransformExpr penv
+          RewriteQuotations = false
+          StackGuard = StackGuard(DetupleRewriteStackGuardDepth) } 
+    assembly |> RewriteImplFile rwenv
 
 //-------------------------------------------------------------------------
 // entry point

src/fsharp/ErrorLogger.fs

@@ -8,6 +8,9 @@ open FSharp.Compiler.Text.Range
 open FSharp.Compiler.Text
 open System
 open System.Diagnostics
+open System.Threading
+open Internal.Utilities.Library
+open Internal.Utilities.Library.Extras
 
 /// Represents the style being used to format errors
 [<RequireQualifiedAccess>]
@@ -433,33 +436,38 @@ module ErrorLoggerExtensions =
 /// NOTE: The change will be undone when the returned "unwind" object disposes
 let PushThreadBuildPhaseUntilUnwind (phase:BuildPhase) =
     let oldBuildPhase = CompileThreadStatic.BuildPhaseUnchecked
-
     CompileThreadStatic.BuildPhase <- phase
-
     { new IDisposable with 
-         member x.Dispose() = CompileThreadStatic.BuildPhase <- oldBuildPhase (* maybe null *) }
+         member x.Dispose() = CompileThreadStatic.BuildPhase <- oldBuildPhase }
 
 /// NOTE: The change will be undone when the returned "unwind" object disposes
-let PushErrorLoggerPhaseUntilUnwind(errorLoggerTransformer : ErrorLogger -> #ErrorLogger) =
+let PushErrorLoggerPhaseUntilUnwind(errorLoggerTransformer: ErrorLogger -> #ErrorLogger) =
     let oldErrorLogger = CompileThreadStatic.ErrorLogger
-    let newErrorLogger = errorLoggerTransformer oldErrorLogger
-    let mutable newInstalled = true
-    let newIsInstalled() = if newInstalled then () else (assert false; (); (*failwith "error logger used after unwind"*)) // REVIEW: ok to throw?
-    let chkErrorLogger = { new ErrorLogger("PushErrorLoggerPhaseUntilUnwind") with
-                             member _.DiagnosticSink(phasedError, isError) = newIsInstalled(); newErrorLogger.DiagnosticSink(phasedError, isError)
-                             member _.ErrorCount = newIsInstalled(); newErrorLogger.ErrorCount }
-
-    CompileThreadStatic.ErrorLogger <- chkErrorLogger
-
+    CompileThreadStatic.ErrorLogger <- errorLoggerTransformer oldErrorLogger
     { new IDisposable with 
          member _.Dispose() =
-            CompileThreadStatic.ErrorLogger <- oldErrorLogger
-            newInstalled <- false }
+            CompileThreadStatic.ErrorLogger <- oldErrorLogger }
 
 let SetThreadBuildPhaseNoUnwind(phase:BuildPhase) = CompileThreadStatic.BuildPhase <- phase
 
 let SetThreadErrorLoggerNoUnwind errorLogger     = CompileThreadStatic.ErrorLogger <- errorLogger
 
+/// This represents the thread-local state established as each task function runs as part of the build.
+///
+/// Use to reset error and warning handlers.
+type CompilationGlobalsScope(errorLogger: ErrorLogger, buildPhase: BuildPhase) = 
+    let unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger)
+    let unwindBP = PushThreadBuildPhaseUntilUnwind buildPhase
+
+    member _.ErrorLogger = errorLogger
+    member _.BuildPhase = buildPhase
+
+    // Return the disposable object that cleans up
+    interface IDisposable with
+        member _.Dispose() =
+            unwindBP.Dispose()         
+            unwindEL.Dispose()
+
 // Global functions are still used by parser and TAST ops.
 
 /// Raises an exception with error recovery and returns unit.
@@ -697,3 +705,36 @@ let internal languageFeatureNotSupportedInLibraryError (langVersion: LanguageVer
     let featureStr = langVersion.GetFeatureString langFeature
     let suggestedVersionStr = langVersion.GetFeatureVersionString langFeature
     error (Error(FSComp.SR.chkFeatureNotSupportedInLibrary(featureStr, suggestedVersionStr), m))
+
+/// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached
+type StackGuard(maxDepth: int) =
+
+    let mutable depth = 1
+
+    member _.Guard(f) =
+        depth <- depth + 1
+        try
+            if depth % maxDepth = 0 then 
+                let errorLogger = CompileThreadStatic.ErrorLogger
+                let buildPhase = CompileThreadStatic.BuildPhase
+                async { 
+                    do! Async.SwitchToNewThread()
+                    Thread.CurrentThread.Name <- "F# Extra Compilation Thread"
+                    use _scope = new CompilationGlobalsScope(errorLogger, buildPhase)
+                    return f()
+                } |> Async.RunImmediate
+            else
+                f()
+        finally
+            depth <- depth - 1
+
+    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
+

src/fsharp/ErrorLogger.fsi

@@ -338,3 +338,24 @@ val checkLanguageFeatureErrorRecover: langVersion:LanguageVersion -> langFeature
 val tryLanguageFeatureErrorOption: langVersion:LanguageVersion -> langFeature:LanguageFeature -> m:range -> exn option
 
 val languageFeatureNotSupportedInLibraryError: langVersion:LanguageVersion -> langFeature:LanguageFeature -> m:range -> 'a
+
+type StackGuard =
+    new: maxDepth: int -> StackGuard
+
+    /// Execute the new function, on a new thread if necessary
+    member Guard: f: (unit -> 'T) -> '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.
+type CompilationGlobalsScope =
+    new: errorLogger: ErrorLogger * buildPhase: BuildPhase -> CompilationGlobalsScope
+
+    interface IDisposable
+
+    member ErrorLogger: ErrorLogger
+
+    member BuildPhase: BuildPhase
+