Guard the stack when checking long sequence expressions

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

@@ -1,5 +1,6 @@
 ### Fixed
 
+* Fix `StackOverflowException` when checking a long `seq { ... }` body. ([PR #20480](https://github.com/dotnet/fsharp/pull/20480))
 * Fix `NativePtr.stackalloc` nested in a larger expression (e.g. a call argument or the right of an assignment) producing an assembly that throws `InvalidProgramException` at load. ([Issue #8083](https://github.com/dotnet/fsharp/issues/8083), [PR #20302](https://github.com/dotnet/fsharp/pull/20302))
 * Fix internal error "Unexpected generalized type variables when compiling an active pattern" when an active pattern is used in a `let` binding whose right-hand side is a generic value, e.g. `let (T) = id`. Such a binding is now checked like the equivalent `match` and is not generalized. ([Issue #16856](https://github.com/dotnet/fsharp/issues/16856), [PR #20383](https://github.com/dotnet/fsharp/pull/20383))
 * Fix Release-only (`--optimize+`) `System.InvalidProgramException` from `Seq.collect` / `yield!` over a value-type (struct) collection implementing `seq<'T>` (e.g. `ImmutableArray<_>`) when materialised with `List.ofSeq` / `Seq.toList` / `Seq.toArray` or a list/array comprehension. The collector lowering now boxes a struct sub-collection to `seq<'T>` before calling `AddMany`/`AddManyAndClose` (matching the coercion the type checker already inserts for `yield!`), and uses `unit` as the try/finally result type instead of the body type (removing a spurious `ldnull` store). ([Issue #20203](https://github.com/dotnet/fsharp/issues/20203))

src/Compiler/Checking/Expressions/CheckSequenceExpressions.fs

@@ -412,45 +412,46 @@ let TcSequenceExpression (cenv: TcFileState) env tpenv comp (overallTy: OverallT
             resExpr, tpenv
 
     and tcSequenceExprBodyAsSequenceOrStatement env genOuterTy tpenv comp =
-        match tryTcSequenceExprBody env genOuterTy tpenv comp with
-        | Some(expr, tpenv) -> Choice1Of2 expr, tpenv
-        | None ->
-
-            let env =
-                { env with
-                    eContextInfo = ContextInfo.SequenceExpression genOuterTy
-                }
-
-            if enableImplicitYield then
-                // The body is speculatively type-checked once to classify it as a statement or a yielded
-                // element. Reporting is buffered so the kept interpretation reports exactly once (else
-                // format-specifier locations and diagnostics double - #16419): a unit statement keeps the
-                // probe result and its buffered reporting is committed; a yielded element drops it and
-                // TcExprFlex re-checks with the element's target type.
-                let hasTypeUnit, _ty, expr, tpenv =
-                    RunWithBufferedReporting
-                        cenv.tcSink
-                        "SeqImplicitYieldProbe"
-                        (fun () -> TryTcStmt cenv env tpenv comp)
-                        (fun (hasTypeUnit, _, _, _) -> hasTypeUnit)
-
-                if hasTypeUnit then
-                    Choice2Of2 expr, tpenv
+        cenv.stackGuard.Guard(fun () ->
+            match tryTcSequenceExprBody env genOuterTy tpenv comp with
+            | Some(expr, tpenv) -> Choice1Of2 expr, tpenv
+            | None ->
+
+                let env =
+                    { env with
+                        eContextInfo = ContextInfo.SequenceExpression genOuterTy
+                    }
+
+                if enableImplicitYield then
+                    // The body is speculatively type-checked once to classify it as a statement or a yielded
+                    // element. Reporting is buffered so the kept interpretation reports exactly once (else
+                    // format-specifier locations and diagnostics double - #16419): a unit statement keeps the
+                    // probe result and its buffered reporting is committed; a yielded element drops it and
+                    // TcExprFlex re-checks with the element's target type.
+                    let hasTypeUnit, _ty, expr, tpenv =
+                        RunWithBufferedReporting
+                            cenv.tcSink
+                            "SeqImplicitYieldProbe"
+                            (fun () -> TryTcStmt cenv env tpenv comp)
+                            (fun (hasTypeUnit, _, _, _) -> hasTypeUnit)
+
+                    if hasTypeUnit then
+                        Choice2Of2 expr, tpenv
+                    else
+                        let genResultTy = NewInferenceType g
+                        let mExpr = expr.Range
+                        UnifyTypes cenv env mExpr genOuterTy (mkSeqTy cenv.g genResultTy)
+                        let expr, tpenv = TcExprFlex cenv flex true genResultTy env tpenv comp
+                        let exprTy = tyOfExpr cenv.g expr
+                        AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css mExpr NoTrace genResultTy exprTy
+
+                        let resExpr =
+                            mkCallSeqSingleton cenv.g mExpr genResultTy (mkCoerceExpr (expr, genResultTy, mExpr, exprTy))
+
+                        Choice1Of2 resExpr, tpenv
                 else
-                    let genResultTy = NewInferenceType g
-                    let mExpr = expr.Range
-                    UnifyTypes cenv env mExpr genOuterTy (mkSeqTy cenv.g genResultTy)
-                    let expr, tpenv = TcExprFlex cenv flex true genResultTy env tpenv comp
-                    let exprTy = tyOfExpr cenv.g expr
-                    AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css mExpr NoTrace genResultTy exprTy
-
-                    let resExpr =
-                        mkCallSeqSingleton cenv.g mExpr genResultTy (mkCoerceExpr (expr, genResultTy, mExpr, exprTy))
-
-                    Choice1Of2 resExpr, tpenv
-            else
-                let stmt, tpenv = TcStmtThatCantBeCtorBody cenv env tpenv comp
-                Choice2Of2 stmt, tpenv
+                    let stmt, tpenv = TcStmtThatCantBeCtorBody cenv env tpenv comp
+                    Choice2Of2 stmt, tpenv)
 
     let coreExpr, tpenv = tcSequenceExprBody env overallTy.Commit tpenv comp
     let delayedExpr = mkSeqDelayedExpr coreExpr.Range coreExpr

src/Compiler/Checking/PostInferenceChecks.fs

@@ -761,7 +761,7 @@ let (|OptionalCoerce|) expr =
 let CheckNoReraise cenv freesOpt (body: Expr) =
     if cenv.reportErrors then
         // Avoid recomputing the free variables
-        let fvs = match freesOpt with None -> freeInExpr CollectLocals body | Some fvs -> fvs
+        let fvs = match freesOpt with None -> freeInExpr (CollectLocalsWithStackGuard()) body | Some fvs -> fvs
         if fvs.UsesUnboundRethrow then
             errorR(Error(FSComp.SR.chkErrorContainsCallToRethrow(), body.Range))
 

tests/FSharp.Compiler.ComponentTests/Language/SequenceExpressions/SequenceExpressionTests.fs

@@ -789,4 +789,18 @@ let f1() =
         |> asExe
         |> ignoreWarnings
         |> compileAndRun
-        |> shouldSucceed
+        |> shouldSucceed
+
+    [<Fact>]
+    let ``Long sequence of implicit yields does not overflow the stack``() =
+        let elements = String.concat "\n" [ for i in 1..1000 -> $"        {{ Name = \"n{i}\"; Id = {i} }}" ]
+        FSharp $"""
+module M
+type Data = {{ Name: string; Id: int }}
+let all =
+    seq {{
+{elements}
+    }}
+"""
+        |> typecheck
+        |> shouldSucceed