diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 9690a6c3c3d..4fb36561100 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -1,6 +1,7 @@ ### Fixed * Fix recursive inline SRTP resolution being truncated by one currying level (e.g. FSharpPlus `memoizeN`), a regression from the function-domain unification order change in [PR #15181](https://github.com/dotnet/fsharp/pull/15181); the contravariant domain now keeps the inference variable that still carries the pending member constraint. ([PR #20247](https://github.com/dotnet/fsharp/pull/20247)) +* Fix exponential (2^N) compile time in pattern matching with shared guards and partial active patterns. ([Issue #18425](https://github.com/dotnet/fsharp/issues/18425), [PR #20244](https://github.com/dotnet/fsharp/pull/20244)) * Fix incorrect `StructLayout(Size = 1)` emission for data-less struct unions where the compiler-generated tag field makes the actual runtime size larger. ([PR #19759](https://github.com/dotnet/fsharp/pull/19759)) * Fix FS0750 "This construct may only be used within computation expressions" incorrectly raised for `let!`/`use!`/`do!` appearing in the right-hand side of a plain `let` binding inside a computation expression. The right-hand side is now desugared as a nested computation of the same builder whose result is bound with `let!`, keeping its bindings correctly scoped. ([Issue #19457](https://github.com/dotnet/fsharp/issues/19457), [PR #19868](https://github.com/dotnet/fsharp/pull/19868)) * Stop leaking a `System.Diagnostics.Metrics.MeterListener` per `Cache` in DEBUG builds. Each cache created a `CacheMetrics.CacheMetricsListener` (which starts a `MeterListener` registered in the process-global metrics registry) and never disposed it, so listeners accumulated for the lifetime of the process. Because every cache hit/miss/add published to all registered listeners, the per-operation cost grew linearly with the number of leaked listeners, so repeated checks (and Debug FCS test runs) slowed down over time. The per-cache `CacheMetricsListener` and the per-instance `cacheId` tag are removed; `DebugDisplay` and tests now read the existing name-aggregated stats populated by the single `ListenToAll` listener, so no per-cache listener is created and no per-operation cost is added. ([PR #19995](https://github.com/dotnet/fsharp/pull/19995)) diff --git a/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs b/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs index 8d4c8259972..c29790c7d7a 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs @@ -85,7 +85,7 @@ let CompilePatternForMatch = let g = cenv.g - let dtree, targets = + let dtree, targets, joins = CompilePattern g env.DisplayEnv @@ -102,6 +102,7 @@ let CompilePatternForMatch resultTy mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy dtree targets + |> mkLetsBind mMatch joins /// Invoke pattern match compilation let CompilePatternForMatchClauses (cenv: TcFileState) env mExpr mMatch warnOnUnused actionOnFailure inputExprOpt inputTy resultTy tclauses = diff --git a/src/Compiler/Checking/PatternMatchCompilation.fs b/src/Compiler/Checking/PatternMatchCompilation.fs index 7f9fd108c67..dd7243ba1fb 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fs +++ b/src/Compiler/Checking/PatternMatchCompilation.fs @@ -396,6 +396,17 @@ type Actives = Active list /// Represents an unresolved portion of pattern matching within a clause type Frontier = Frontier of ClauseNumber * Actives * ValMap +// Keep in sync with pathEq: equal keys may share one compiled residual state. +let rec private frontierPathKey p = + match p with + | PathQuery(p, n) -> "Q" + string n + frontierPathKey p + | PathTuple(p, _, n) -> "T" + string n + frontierPathKey p + | PathRecd(p, _, _, n) -> "R" + string n + frontierPathKey p + | PathUnionConstr(p, _, _, n) -> "U" + string n + frontierPathKey p + | PathArray(p, _, i1, i2) -> "A" + string i1 + "_" + string i2 + frontierPathKey p + | PathExnConstr(p, _, n) -> "E" + string n + frontierPathKey p + | PathEmpty _ -> "." + type InvestigationPoint = Investigation of ClauseNumber * DecisionTreeTest * Path // Note: actives must be a SortedDictionary @@ -1128,9 +1139,101 @@ let CompilePatternBasic getDiscrimOfPattern g unit_tpinst // The main recursive loop of the pattern match compiler. + + // Repeated states stay inline until the threshold, preserving ordinary match output. + let stackGuard = StackGuard("InvestigateFrontiers") + let joinPromotionThreshold = 32 + let isThunkableTy ty = not (isByrefLikeTy g mExpr ty) && not (isByrefTy g ty) + let joinBindings = ResizeArray() + let frontierMemo = Dictionary * Lazy>() + + // The full body includes clause targets, which may contain constructs that cannot move into a lambda. + let isLiftableJoinBody body = + let fvs = freeInExpr (CollectLocalsWithStackGuard()) body + not fvs.UsesUnboundRethrow + && not fvs.UsesMethodLocalConstructs + && not (fvs.ContainsILFieldAccess && exprReferencesProtectedILField amap body) + && isThunkableTy resultTy + && fvs.FreeLocals + |> Internal.Utilities.Collections.Zset.forall (fun v -> + v.ValReprInfo.IsSome + || (v.BaseOrThisInfo = NormalVal + && isThunkableTy v.Type + && not (IsGenericValWithGenericConstraints g v) + && not v.IsMutable)) + + // Reference identities make key collisions conservative: distinct nodes never fuse. + let patternNodeId = + let ids = System.Collections.Generic.Dictionary(HashIdentity.Reference) + fun (pat: Pattern) -> + match ids.TryGetValue pat with + | true, v -> v + | _ -> + let v = ids.Count + ids[pat] <- v + v + + let frontierActiveKey (Active(path, _, pat)) = + frontierPathKey path + "#" + string (patternNodeId pat) + + let boundExprNodeId = + let ids = System.Collections.Generic.Dictionary(HashIdentity.Reference) + fun (e: Expr) -> + match ids.TryGetValue e with + | true, v -> v + | _ -> + let v = ids.Count + ids[e] <- v + v + + let rec boundExprKey (e: Expr) = + match stripDebugPoints e with + | Expr.Val(vref, _, _) -> "v" + string vref.Stamp + | Expr.Op(TOp.TupleFieldGet(_, j), _, [ arg ], _) -> "t" + string j + "(" + boundExprKey arg + ")" + | Expr.Op(TOp.ValFieldGet rfref, _, args, _) -> "r" + rfref.FieldName + "(" + String.concat "," (List.map boundExprKey args) + ")" + | Expr.Op(TOp.UnionCaseFieldGet(ucref, j), _, args, _) -> "u" + ucref.CaseName + "_" + string j + "(" + String.concat "," (List.map boundExprKey args) + ")" + | Expr.Op(TOp.Coerce, _, [ arg ], _) -> "c(" + boundExprKey arg + ")" + | _ -> "?" + string (boundExprNodeId e) + + let frontierValMapKey (valMap: ValMap) = + if valMap.IsEmpty then + "" + else + valMap.Contents + |> Seq.map (fun (KeyValue (stamp, boundExpr)) -> string stamp + "=" + boundExprKey boundExpr) + |> Seq.sort + |> String.concat ";" + + let frontiersStateKey frontiers = + frontiers + |> List.map (fun (Frontier(i, actives, valMap)) -> + string i + ":" + String.concat "," (List.map frontierActiveKey actives) + "{" + frontierValMapKey valMap + "}") + |> String.concat "|" + + // The match input stays in scope at the outer join binding; only tree-bound locals need parameters. + let capturedValsOfFrontiers frontiers = + let acc = System.Collections.Generic.Dictionary() + let addFreeLocals (e: Expr) = + for v in Internal.Utilities.Collections.Zset.elements (freeInExpr CollectLocals e).FreeLocals do + if v.Stamp <> origInputVal.Stamp then acc[v.Stamp] <- v + for Frontier(_, actives, valMap) in frontiers do + for Active(_, subexpr, _) in actives do + addFreeLocals (GetSubExprOfInput subexpr) + for KeyValue(_, boundExpr) in valMap.Contents do + addFreeLocals boundExpr + acc.Values |> List.ofSeq |> List.sortBy (fun v -> v.Stamp) + + let callJoinThunk (joinE: Expr) (joinThunkTy: TType) (caps: Val list) = + let targetParams = caps |> List.map (fun v -> fst (mkCompGenLocal mMatch "joinArg" v.Type)) + let args = (targetParams |> List.map (exprForVal mMatch)) @ [mkUnit g mMatch] + let idx = matchBuilder.AddTarget(TTarget(targetParams, mkApps g ((joinE, joinThunkTy), [], args, mMatch), None)) + TDSuccess(caps |> List.map (exprForVal mMatch), idx) + let rec InvestigateFrontiers refuted frontiers = Cancellable.CheckAndThrow() + stackGuard.Guard(fun () -> InvestigateFrontiersImpl refuted frontiers) + and InvestigateFrontiersImpl refuted frontiers = match frontiers with | [] -> failwith "CompilePattern: compile - empty clauses: at least the final clause should always succeed" | Frontier (i, active, valMap) :: rest -> @@ -1181,11 +1284,50 @@ let CompilePatternBasic | Some whenExpr -> let m = whenExpr.Range let whenExprWithBindings = mkLetsFromBindings m (mkInvisibleBinds vs2 es2) whenExpr - let failureTree = (InvestigateFrontiers (RefutedWhenClause :: refuted) rest) + let failureTree = investigateMemoized (RefutedWhenClause :: refuted) rest mkBoolSwitch m whenExprWithBindings successTree failureTree | None -> successTree + and investigateMemoized refuted frontiers = + if warnOnIncomplete then + InvestigateFrontiers refuted frontiers + else + let caps = capturedValsOfFrontiers frontiers + let key = + frontiersStateKey frontiers + "|CAP:" + (caps |> List.map (fun v -> string v.Stamp) |> String.concat ",") + match frontierMemo.TryGetValue key with + | true, (count, promotable, shared) -> + count.Value <- count.Value + 1 + if (shared.IsValueCreated || count.Value > joinPromotionThreshold) && promotable.Value then + let joinE, joinThunkTy = shared.Value + callJoinThunk joinE joinThunkTy caps + else + InvestigateFrontiers refuted frontiers + | _ -> + let subtree = InvestigateFrontiers refuted frontiers + let joinBody = + lazy (mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy subtree (matchBuilder.CloseTargets())) + let promotable = + lazy + (match subtree with TDSuccess _ -> false | _ -> true) + && isLiftableJoinBody joinBody.Value + let shared = + lazy + let paramVals = caps |> List.map (fun v -> fst (mkCompGenLocal mMatch "joinCap" v.Type)) + let remap = + { Remap.Empty with + valRemap = ValMap.OfList (List.map2 (fun (c: Val) (p: Val) -> c, mkLocalValRef p) caps paramVals) } + let body = remapExpr g CloneAll remap joinBody.Value + let unitV, _ = mkCompGenLocal mMatch "unitArg" g.unit_ty + let joinThunkTy = List.foldBack (fun (p: Val) acc -> mkFunTy g p.Type acc) paramVals (mkFunTy g g.unit_ty resultTy) + let joinLam = mkLambdas g mMatch [] (paramVals @ [unitV]) (body, resultTy) + let joinV, joinE = mkCompGenLocal mMatch "joinThunk" joinThunkTy + joinBindings.Add(mkInvisibleBind joinV joinLam) + (joinE, joinThunkTy) + frontierMemo[key] <- ref 1, promotable, shared + subtree + /// Select the set of discriminators which we can handle in one test, or as a series of iterated tests, /// e.g. in the case of TPat_isinst. Ensure we only take at most one class of `TPat_query` at a time. /// Record the clause numbers so we know which rule the TPat_query cam from, so that when we project through @@ -1340,7 +1482,7 @@ let CompilePatternBasic let frontiers = frontiers |> List.collect (GenerateNewFrontiersAfterSuccessfulInvestigation taken inpExprOpt resPostBindOpt investigation) - let tree = InvestigateFrontiers refuted frontiers + let tree = investigateMemoized refuted frontiers // Bind the resVar for the union case, if we have one let tree = @@ -1379,7 +1521,7 @@ let CompilePatternBasic | [] -> None | _ -> - Some(InvestigateFrontiers refuted fallthroughPathFrontiers) + Some(investigateMemoized refuted fallthroughPathFrontiers) // Build a new frontier that represents the result of a successful investigation and GenerateNewFrontiersAfterSuccessfulInvestigation taken inpExprOpt resPostBindOpt investigation frontier = @@ -1641,7 +1783,7 @@ let CompilePatternBasic if warnOnUnused then ReportUnusedTargets clauses dtree - dtree, matchBuilder.CloseTargets() + dtree, matchBuilder.CloseTargets(), List.ofSeq joinBindings // Three pattern constructs can cause significant code expansion in various combinations // - Partial active patterns @@ -1728,10 +1870,10 @@ let rec CompilePattern g denv amap tcVal infoReader mExpr mMatch warnOnUnused a and doGroupWithAtMostOneProblematic group rest = // Compile the remaining clauses. - let decisionTree, targets = atMostOneProblematicClauseAtATime rest + let decisionTree, targets, joins = atMostOneProblematicClauseAtATime rest // Make the expression that represents the remaining cases of the pattern match. - let expr = mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy decisionTree targets + let expr = mkLetsBind mMatch joins (mkAndSimplifyMatch DebugPointAtBinding.NoneAtInvisible mExpr mMatch resultTy decisionTree targets) // Make the clause that represents the remaining cases of the pattern match let clauseForRestOfMatch = MatchClause(TPat_wild mMatch, None, TTarget(List.empty, expr, None), mMatch) diff --git a/src/Compiler/Checking/PatternMatchCompilation.fsi b/src/Compiler/Checking/PatternMatchCompilation.fsi index 8afdc2992f3..c3a6da51db2 100644 --- a/src/Compiler/Checking/PatternMatchCompilation.fsi +++ b/src/Compiler/Checking/PatternMatchCompilation.fsi @@ -69,7 +69,7 @@ val internal CompilePattern: TType -> // result type TType -> - DecisionTree * DecisionTreeTarget list + DecisionTree * DecisionTreeTarget list * Bindings /// Exception raised when a pattern match is incomplete. /// Fields: isComputationExpression * (counterExample * isShownAsFieldPattern) option * range diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ExpressionQuotations/QuotationRendering/QuotationRenderingTests.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ExpressionQuotations/QuotationRendering/QuotationRenderingTests.fs index ed6567fe88b..642b57ac550 100644 --- a/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ExpressionQuotations/QuotationRendering/QuotationRenderingTests.fs +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ExpressionQuotations/QuotationRendering/QuotationRenderingTests.fs @@ -19,16 +19,15 @@ module QuotationRendering = let private fsiSession = getSessionForEval [||] LangVersion.Preview - let private quoteShouldRender (name: string) (quoteExpr: string) = - let result = - Fsx (sprintf "printfn \"%%A\" %s" quoteExpr) - |> evalInSharedSession fsiSession - |> shouldSucceed + let private renderFsx source = + let result = Fsx source |> evalInSharedSession fsiSession |> shouldSucceed + match result.RunOutput with - | Some (EvalOutput e) -> - checkBaseline (e.StdOut |> normalizeNewlines) (Path.Combine(baselineDir, name + ".bsl")) - | _ -> - failwith "Expected eval output from shared FSI session." + | Some(EvalOutput e) -> e.StdOut |> normalizeNewlines + | _ -> failwith "Expected eval output from shared FSI session." + + let private quoteShouldRender (name: string) (quoteExpr: string) = + checkBaseline (renderFsx (sprintf "printfn \"%%A\" %s" quoteExpr)) (Path.Combine(baselineDir, name + ".bsl")) [] let EmptyString () = @@ -71,12 +70,26 @@ let viaRecord = <@ { A = 1; B = 2 } @> System.Console.WriteLine(viaCtor.ToString()) System.Console.WriteLine(viaCtor.ToString() = viaRecord.ToString()) """ - let result = - Fsx source - |> evalInSharedSession fsiSession - |> shouldSucceed - match result.RunOutput with - | Some (EvalOutput e) -> - checkBaseline (e.StdOut |> normalizeNewlines) (Path.Combine(baselineDir, "RecordConstructor.bsl")) - | _ -> - failwith "Expected eval output from shared FSI session." + checkBaseline (renderFsx source) (Path.Combine(baselineDir, "RecordConstructor.bsl")) + + let private renderGuardedOrQuote quoteExpr = + renderFsx ( + "let (|E|_|) (n: int) (x: int) = if x = n then Some x else None\n" + + "let (|A|_|) (x: int) = if x % 2 = 0 then Some (x / 2) else None\n" + + "let g (p: int) = p > 1000\n" + + sprintf "printfn \"%%A\" %s" quoteExpr + ) + + [] + [] + [] + let ``Issue 18425 - guarded shared-or shares quotations only above the threshold`` disjunctCount expectJoin = + let patterns = [ 1..disjunctCount ] |> List.map (sprintf "E %d _") |> String.concat " | " + let rendered = renderGuardedOrQuote (sprintf "<@ fun (x: int) -> match x with (%s) when g 0 -> 1 | _ -> 0 @>" patterns) + if expectJoin then Assert.Contains("joinThunk", rendered) else Assert.DoesNotContain("joinThunk", rendered) + + [] + let ``Issue 18425 - shared join threads a bound pattern variable through the tuple or-pattern`` () = + let patterns = [ 1..8 ] |> List.map (sprintf "(A p, E %d _)") |> String.concat " | " + let rendered = renderGuardedOrQuote (sprintf "<@ fun (a: int) (b: int) -> match a, b with %s when g p -> p | _ -> 0 @>" patterns) + Assert.Contains("joinThunk", rendered) diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/GuardedOrPatternComplexity.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/GuardedOrPatternComplexity.fs new file mode 100644 index 00000000000..b34ebe5fa70 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/PatternMatching/GuardedOrPatternComplexity.fs @@ -0,0 +1,112 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Conformance.PatternMatching + +open Xunit +open FSharp.Test.Compiler + +module GuardedOrPatternComplexity = + + // https://github.com/dotnet/fsharp/issues/18425 + let private runsWith expected source = + source + |> FSharp + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains expected + + let private compiles source = + source |> FSharp |> compile |> shouldSucceed + + let private guardedOrSource n = + let disjuncts = + [ for k in 1..n -> sprintf " | (A p, E %d _)" k ] + |> String.concat "\n" + + let template = """module Test +let (|A|_|) (x: int) = if x % 2 = 0 then Some(x / 2) else None +let (|E|_|) (n: int) (x: int) = if x = n then Some x else None +let g (p: int) = p > 1000 +let f (a: int) (b: int) = + match a, b with +__DISJUNCTS__ + when g p -> p + | _ -> -1 +[] +let main _ = + let r1 = f 8 3 + let r2 = f 4000 1 + printfn "r1=%d r2=%d" r1 r2 + 0 +""" + + template.Replace("__DISJUNCTS__", disjuncts) + + [] + let ``Issue 18425 - guarded shared-or partial active pattern match compiles and runs`` () = + guardedOrSource 24 + |> runsWith "r1=-1 r2=2000" + + [] + let ``Issue 18425 - shared guard binding a variable at different positions is not over-fused`` () = + """module Test +let (|Z|_|) (v: int) = if v = 0 then Some() else None +let (|Pos|_|) (v: int) = if v > 100 then Some v else None +let f (t: int*int*int*int*int*int*int*int) = + match t with + | (Pos x, Z, Z, Z, Z, Z, Z, Z) + | (Z, Pos x, Z, Z, Z, Z, Z, Z) + | (Z, Z, Pos x, Z, Z, Z, Z, Z) + | (Z, Z, Z, Pos x, Z, Z, Z, Z) + | (Z, Z, Z, Z, Pos x, Z, Z, Z) + | (Z, Z, Z, Z, Z, Pos x, Z, Z) + | (Z, Z, Z, Z, Z, Z, Pos x, Z) + | (Z, Z, Z, Z, Z, Z, Z, Pos x) when x > 100 -> x + | _ -> -1 +[] +let main _ = + printfn "%d %d %d %d" (f (150,0,0,0,0,0,0,0)) (f (0,0,0,160,0,0,0,0)) (f (0,0,0,0,0,0,0,170)) (f (1,2,3,4,5,6,7,8)) + 0 +""" + |> runsWith "150 160 170 -1" + + [] + let ``Issue 18425 - guarded shared-or returning a byref stays inline and compiles`` () = + """module Test +let (|E|_|) (n: int) (x: int) = if x = n then Some x else None +let f (arr: int[]) (b: int) : byref = + match b with + | E 1 _ | E 2 _ | E 3 _ | E 4 _ | E 5 _ | E 6 _ | E 7 _ | E 8 _ when arr.Length > 2 -> &arr[0] + | _ -> &arr[1] +[] +let main _ = + let arr = [| 10; 20; 30 |] + (f arr 3) <- 99 + (f arr 42) <- 77 + printfn "%d %d" arr[0] arr[1] + 0 +""" + |> runsWith "99 77" + + [] + let ``Issue 18425 - guarded shared-or in a catch handler can rethrow`` () = + """module Test +let (|E|_|) (n: int) (e: exn) = if e.Message = string n then Some() else None +let f () = + try failwith "1" with + | (E 1 | E 2 | E 3 | E 4 | E 5 | E 6 | E 7 | E 8) when System.DateTime.UtcNow.Ticks >= 0L -> 1 + | _ -> reraise() +""" + |> compiles + + [] + let ``Issue 18425 - guarded shared-or with a byref-like clause target stays inline`` () = + """module Test +open System +let (|E|_|) (n: int) (x: int) = if x = n then Some x else None +let f (buffer: Span) x = + match x with + | E 1 _ | E 2 _ | E 3 _ | E 4 _ | E 5 _ | E 6 _ | E 7 _ | E 8 _ when System.DateTime.UtcNow.Ticks >= 0L -> buffer.Length + | _ -> 0 +""" + |> compiles diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 2d033e260dc..485f93f534e 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -156,6 +156,7 @@ +