Many match clauses

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

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 ->
 

tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj

@@ -246,6 +246,7 @@
     <Compile Include="TypeChecks\TyparNameTests.fs" />
     <Compile Include="TypeChecks\CheckTypeTests.fs" />
     <Compile Include="TypeChecks\TypeExtensions\PropertyShadowingTests.fs" />
+    <Compile Include="TypeChecks\PatternMatchTests.fs" />
     <Compile Include="CompilerOptions\fsc\checked\checked.fs" />
     <Compile Include="CompilerOptions\fsc\cliversion.fs" />
     <Compile Include="CompilerOptions\fsc\codepage\codepage.fs" />

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 =
+
+    [<Fact>]
+    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