From b099252d6c49d34c3306a639bd44a1f7c6e4185f Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 13 Dec 2023 17:15:15 +0100 Subject: [PATCH 1/3] Add failing unit test --- .../FSharp.Compiler.ComponentTests.fsproj | 1 + .../TypeChecks/PatternMatchTests.fs | 38 +++++++++++++++++++ 2 files changed, 39 insertions(+) create mode 100644 tests/FSharp.Compiler.ComponentTests/TypeChecks/PatternMatchTests.fs diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 70221cde693..c016020404c 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -246,6 +246,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/TypeChecks/PatternMatchTests.fs b/tests/FSharp.Compiler.ComponentTests/TypeChecks/PatternMatchTests.fs new file mode 100644 index 00000000000..be5c2fec85e --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/TypeChecks/PatternMatchTests.fs @@ -0,0 +1,38 @@ +namespace TypeChecks + +open Xunit +open NUnit.Framework +open FSharp.Test +open FSharp.Test.Compiler + +module PatternMatchTests = + + [] + let ``Over 9000 match clauses`` () = + let max = 9001 + + let aSource = + let me = + [ 0 .. max ] + |> List.map (fun i -> $" | %i{i} -> %i{i} + 1") + |> String.concat "\n" + |> sprintf """let f (a: int) : int = + match a with +%s + | i -> i + 1 + """ + + $"module A\n\n%s{me}" + + let bSource = """module B + +open A + +let g = f 0 +""" + + FSharp aSource + |> withAdditionalSourceFile (FsSource bSource) + |> typecheckResults + |> fun results -> + Assert.IsEmpty results.Diagnostics From 2557044ec05e3bc1a239667d8405f3a08f391821 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 13 Dec 2023 17:15:37 +0100 Subject: [PATCH 2/3] Inline TcMatchClause to avoid stackoverflow. --- src/Compiler/Checking/CheckExpressions.fs | 32 +++++++++++------------ 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 6f169d474a8..cfc2088ecf1 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -10327,26 +10327,26 @@ and TcMatchPattern cenv inputTy env tpenv (synPat: SynPat) (synWhenExprOpt: SynE and TcMatchClauses cenv inputTy (resultTy: OverallTy) env tpenv clauses = let mutable first = true let isFirst() = if first then first <- false; true else false - List.mapFold (fun clause -> TcMatchClause cenv inputTy resultTy env (isFirst()) clause) tpenv clauses + (tpenv, clauses) + ||> List.mapFold (fun tpenv synMatchClause -> + let isFirst = isFirst() + let (SynMatchClause(synPat, synWhenExprOpt, synResultExpr, patm, spTgt, _)) = synMatchClause + let pat, whenExprOpt, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv synPat synWhenExprOpt -and TcMatchClause cenv inputTy (resultTy: OverallTy) env isFirst tpenv synMatchClause = - let (SynMatchClause(synPat, synWhenExprOpt, synResultExpr, patm, spTgt, _)) = synMatchClause - let pat, whenExprOpt, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv synPat synWhenExprOpt + let resultEnv = + if isFirst then envinner + else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause synResultExpr.Range } - let resultEnv = - if isFirst then envinner - else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause synResultExpr.Range } + let resultEnv = + match spTgt with + | DebugPointAtTarget.Yes -> { resultEnv with eIsControlFlow = true } + | DebugPointAtTarget.No -> resultEnv - let resultEnv = - match spTgt with - | DebugPointAtTarget.Yes -> { resultEnv with eIsControlFlow = true } - | DebugPointAtTarget.No -> resultEnv + let resultExpr, tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv synResultExpr - let resultExpr, tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv synResultExpr - - let target = TTarget(vspecs, resultExpr, None) - - MatchClause(pat, whenExprOpt, target, patm), tpenv + let target = TTarget(vspecs, resultExpr, None) + + MatchClause(pat, whenExprOpt, target, patm), tpenv) and TcStaticOptimizationConstraint cenv env tpenv c = let g = cenv.g From cce77d7851da62084b650c9124a60bfb700447cf Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 13 Dec 2023 17:15:50 +0100 Subject: [PATCH 3/3] Remove rec keyword --- src/Compiler/Checking/PatternMatchCompilation.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index 3caacecb982..2fff7e31b0a 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -1733,7 +1733,7 @@ let isProblematicClause (clause: MatchClause) = let ips = investigationPoints clause.Pattern ips.Length > 0 && Span.exists id (ips.AsSpan (0, ips.Length - 1)) -let rec CompilePattern g denv amap tcVal infoReader mExpr mMatch warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: MatchClause list) inputTy resultTy = +let CompilePattern g denv amap tcVal infoReader mExpr mMatch warnOnUnused actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (clausesL: MatchClause list) inputTy resultTy = match clausesL with | _ when List.exists isProblematicClause clausesL ->