From 0b6ddc7019aa70ba285b658211f0a93e97e93eb4 Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Fri, 26 Apr 2024 10:38:10 +0200 Subject: [PATCH 1/9] Added simple caching for TC results of implicit-yield expressions. This avoids exponential blowup when checking nested builders with implicit yields --- src/Compiler/Checking/CheckBasics.fs | 4 + src/Compiler/Checking/CheckBasics.fsi | 4 + src/Compiler/Checking/CheckDeclarations.fs | 3 +- src/Compiler/Checking/CheckExpressions.fs | 174 +++++++++++---------- 4 files changed, 103 insertions(+), 82 deletions(-) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index bbfa5557b2d..b5ed3f8b6c0 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -243,6 +243,10 @@ type TcEnv = // Do we lay down an implicit debug point? eIsControlFlow: bool + + // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. + // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. + eCachedImplicitYieldExpressions : list } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index e3ad581cb61..eeff25f5740 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -128,6 +128,10 @@ type TcEnv = eLambdaArgInfos: ArgReprInfo list list eIsControlFlow: bool + + // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. + // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. + eCachedImplicitYieldExpressions : list } member DisplayEnv: DisplayEnv diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 4ecd8f4824a..e96ba45b23b 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5536,7 +5536,8 @@ let emptyTcEnv g = eCtorInfo = None eCallerMemberName = None eLambdaArgInfos = [] - eIsControlFlow = false } + eIsControlFlow = false + eCachedImplicitYieldExpressions = [] } let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) = (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 528ea757116..44582d5a703 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5335,100 +5335,106 @@ and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg /// method applications and other item-based syntax. and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let g = cenv.g + + match env.eCachedImplicitYieldExpressions |> List.tryPick (fun (se, e) -> if System.Object.ReferenceEquals(se, synExpr) then Some e else None) with + | Some expr -> + expr, tpenv + | _ -> + - match synExpr with - - // A. - // A.B. - | SynExpr.DiscardAfterMissingQualificationAfterDot (expr1, _, m) -> - let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownTypeThen cenv env tpenv expr1 [DelayedDot]) - mkDefault(m, overallTy.Commit), tpenv - - // A - // A.B.C - | LongOrSingleIdent (isOpt, longId, altNameRefCellOpt, mLongId) -> - TcNonControlFlowExpr env <| fun env -> + match synExpr with - if isOpt then errorR(Error(FSComp.SR.tcSyntaxErrorUnexpectedQMark(), mLongId)) + // A. + // A.B. + | SynExpr.DiscardAfterMissingQualificationAfterDot (expr1, _, m) -> + let _, _, tpenv = suppressErrorReporting (fun () -> TcExprOfUnknownTypeThen cenv env tpenv expr1 [DelayedDot]) + mkDefault(m, overallTy.Commit), tpenv - // Check to see if pattern translation decided to use an alternative identifier. - match altNameRefCellOpt with - | Some {contents = SynSimplePatAlternativeIdInfo.Decided altId} -> - TcExprThen cenv overallTy env tpenv isArg (SynExpr.LongIdent (isOpt, SynLongIdent([altId], [], [None]), None, mLongId)) delayed - | _ -> - TcLongIdentThen cenv overallTy env tpenv longId delayed + // A + // A.B.C + | LongOrSingleIdent (isOpt, longId, altNameRefCellOpt, mLongId) -> + TcNonControlFlowExpr env <| fun env -> - // f?x<-v - | SynExpr.Set(SynExpr.Dynamic(e1, _, e2, _) , rhsExpr, m) -> - TcExprThenSetDynamic cenv overallTy env tpenv isArg e1 e2 rhsExpr m delayed - - // f x - // f(x) // hpa=true - // f[x] // hpa=true - | SynExpr.App (hpa, isInfix, func, arg, mFuncAndArg) -> - match func with - | SynExpr.DotLambda _ -> errorR(Error(FSComp.SR.tcDotLambdaAtNotSupportedExpression(), func.Range)) - | _ -> () + if isOpt then errorR(Error(FSComp.SR.tcSyntaxErrorUnexpectedQMark(), mLongId)) - TcNonControlFlowExpr env <| fun env -> - - CheckForAdjacentListExpression cenv synExpr hpa isInfix delayed arg + // Check to see if pattern translation decided to use an alternative identifier. + match altNameRefCellOpt with + | Some {contents = SynSimplePatAlternativeIdInfo.Decided altId} -> + TcExprThen cenv overallTy env tpenv isArg (SynExpr.LongIdent (isOpt, SynLongIdent([altId], [], [None]), None, mLongId)) delayed + | _ -> + TcLongIdentThen cenv overallTy env tpenv longId delayed - TcExprThen cenv overallTy env tpenv false func ((DelayedApp (hpa, isInfix, Some func, arg, mFuncAndArg)) :: delayed) + // f?x<-v + | SynExpr.Set(SynExpr.Dynamic(e1, _, e2, _) , rhsExpr, m) -> + TcExprThenSetDynamic cenv overallTy env tpenv isArg e1 e2 rhsExpr m delayed + + // f x + // f(x) // hpa=true + // f[x] // hpa=true + | SynExpr.App (hpa, isInfix, func, arg, mFuncAndArg) -> + match func with + | SynExpr.DotLambda _ -> errorR(Error(FSComp.SR.tcDotLambdaAtNotSupportedExpression(), func.Range)) + | _ -> () - // e1?e2 - | SynExpr.Dynamic(e1, mQmark, e2, _) -> - TcExprThenDynamic cenv overallTy env tpenv isArg e1 mQmark e2 delayed + TcNonControlFlowExpr env <| fun env -> + + CheckForAdjacentListExpression cenv synExpr hpa isInfix delayed arg - // e - | SynExpr.TypeApp (func, _, typeArgs, _, _, mTypeArgs, mFuncAndTypeArgs) -> - TcExprThen cenv overallTy env tpenv false func ((DelayedTypeApp (typeArgs, mTypeArgs, mFuncAndTypeArgs)) :: delayed) + TcExprThen cenv overallTy env tpenv false func ((DelayedApp (hpa, isInfix, Some func, arg, mFuncAndArg)) :: delayed) - // expr1.id1 - // expr1.id1.id2 - // etc. - | SynExpr.DotGet (expr1, _, SynLongIdent(longId, _, _), _) -> - TcNonControlFlowExpr env <| fun env -> - TcExprThen cenv overallTy env tpenv false expr1 ((DelayedDotLookup (longId, synExpr.Range)) :: delayed) + // e1?e2 + | SynExpr.Dynamic(e1, mQmark, e2, _) -> + TcExprThenDynamic cenv overallTy env tpenv isArg e1 mQmark e2 delayed - // expr1.[expr2] - // expr1.[e21, ..., e2n] - // etc. - | SynExpr.DotIndexedGet (expr1, IndexerArgs indexArgs, mDot, mWholeExpr) -> - TcNonControlFlowExpr env <| fun env -> - if not isArg && g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then - informationalWarning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) - TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv None expr1 indexArgs delayed - - // expr1.[expr2] <- expr3 - // expr1.[e21, ..., e2n] <- expr3 - // etc. - | SynExpr.DotIndexedSet (expr1, IndexerArgs indexArgs, expr3, mOfLeftOfSet, mDot, mWholeExpr) -> - TcNonControlFlowExpr env <| fun env -> - if g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then - warning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) - // Wrap in extra parens: like MakeDelayedSet, - // but we don't actually want to delay it here. - let setInfo = SynExpr.Paren (expr3, range0, None, expr3.Range), mOfLeftOfSet - TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv (Some setInfo) expr1 indexArgs delayed + // e + | SynExpr.TypeApp (func, _, typeArgs, _, _, mTypeArgs, mFuncAndTypeArgs) -> + TcExprThen cenv overallTy env tpenv false func ((DelayedTypeApp (typeArgs, mTypeArgs, mFuncAndTypeArgs)) :: delayed) - // Part of 'T.Ident - | SynExpr.Typar (typar, m) -> - TcTyparExprThen cenv overallTy env tpenv typar m delayed + // expr1.id1 + // expr1.id1.id2 + // etc. + | SynExpr.DotGet (expr1, _, SynLongIdent(longId, _, _), _) -> + TcNonControlFlowExpr env <| fun env -> + TcExprThen cenv overallTy env tpenv false expr1 ((DelayedDotLookup (longId, synExpr.Range)) :: delayed) - // ^expr - | SynExpr.IndexFromEnd (rightExpr, m) -> - errorR(Error(FSComp.SR.tcTraitInvocationShouldUseTick(), m)) - // Incorporate the '^' into the rightExpr, producing a nested SynExpr.Typar - let adjustedExpr = ParseHelpers.adjustHatPrefixToTyparLookup m rightExpr - TcExprThen cenv overallTy env tpenv isArg adjustedExpr delayed + // expr1.[expr2] + // expr1.[e21, ..., e2n] + // etc. + | SynExpr.DotIndexedGet (expr1, IndexerArgs indexArgs, mDot, mWholeExpr) -> + TcNonControlFlowExpr env <| fun env -> + if not isArg && g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then + informationalWarning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) + TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv None expr1 indexArgs delayed + + // expr1.[expr2] <- expr3 + // expr1.[e21, ..., e2n] <- expr3 + // etc. + | SynExpr.DotIndexedSet (expr1, IndexerArgs indexArgs, expr3, mOfLeftOfSet, mDot, mWholeExpr) -> + TcNonControlFlowExpr env <| fun env -> + if g.langVersion.SupportsFeature LanguageFeature.IndexerNotationWithoutDot then + warning(Error(FSComp.SR.tcIndexNotationDeprecated(), mDot)) + // Wrap in extra parens: like MakeDelayedSet, + // but we don't actually want to delay it here. + let setInfo = SynExpr.Paren (expr3, range0, None, expr3.Range), mOfLeftOfSet + TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv (Some setInfo) expr1 indexArgs delayed + + // Part of 'T.Ident + | SynExpr.Typar (typar, m) -> + TcTyparExprThen cenv overallTy env tpenv typar m delayed + + // ^expr + | SynExpr.IndexFromEnd (rightExpr, m) -> + errorR(Error(FSComp.SR.tcTraitInvocationShouldUseTick(), m)) + // Incorporate the '^' into the rightExpr, producing a nested SynExpr.Typar + let adjustedExpr = ParseHelpers.adjustHatPrefixToTyparLookup m rightExpr + TcExprThen cenv overallTy env tpenv isArg adjustedExpr delayed - | _ -> - match delayed with - | [] -> TcExprUndelayed cenv overallTy env tpenv synExpr | _ -> - let expr, exprTy, tpenv = TcExprUndelayedNoType cenv env tpenv synExpr - PropagateThenTcDelayed cenv overallTy env tpenv synExpr.Range (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.NonAtomic delayed + match delayed with + | [] -> TcExprUndelayed cenv overallTy env tpenv synExpr + | _ -> + let expr, exprTy, tpenv = TcExprUndelayedNoType cenv env tpenv synExpr + PropagateThenTcDelayed cenv overallTy env tpenv synExpr.Range (MakeApplicableExprNoFlex cenv expr) exprTy ExprAtomicFlag.NonAtomic delayed and TcExprThenSetDynamic (cenv: cenv) overallTy env tpenv isArg e1 e2 rhsExpr m delayed = let e2 = mkDynamicArgExpr e2 @@ -6177,7 +6183,13 @@ and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExp // The first expression wasn't unit-typed, so proceed to the alternative interpretation // Note a copy of the first expression is embedded in 'otherExpr' and thus // this will type-check the first expression over again. - TcExpr cenv overallTy env tpenv otherExpr + let cachedExpr = + match expr1 with + | Expr.DebugPoint(_,e) -> e + | _ -> expr1 + + let newEnv = { env with eCachedImplicitYieldExpressions = (synExpr1, cachedExpr) :: env.eCachedImplicitYieldExpressions } + TcExpr cenv overallTy newEnv tpenv otherExpr and TcExprStaticOptimization (cenv: cenv) overallTy env tpenv (constraints, synExpr2, expr3, m) = let constraintsR, tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints From 07fd43252e75d39930305dc52a3594a478117c56 Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Fri, 26 Apr 2024 12:01:25 +0200 Subject: [PATCH 2/9] added CE nesting benchmark and added EmptyCache option to benchmarks --- .../ComputationExpressionBenchmarks.fs | 13 ++++- .../ce/CE1xnest15.fs | 55 +++++++++++++++++++ 2 files changed, 66 insertions(+), 2 deletions(-) create mode 100644 tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ce/CE1xnest15.fs diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ComputationExpressionBenchmarks.fs b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ComputationExpressionBenchmarks.fs index 815d4818344..f3cafd97de0 100644 --- a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ComputationExpressionBenchmarks.fs +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ComputationExpressionBenchmarks.fs @@ -11,10 +11,10 @@ open FSharp.Benchmarks.Common.Categories type ComputationExpressionBenchmarks() = let mutable sourceFileName = "" - [] @@ -22,6 +22,9 @@ type ComputationExpressionBenchmarks() = with get () = File.ReadAllText(__SOURCE_DIRECTORY__ ++ "ce" ++ sourceFileName) and set f = sourceFileName <- f + [] + member val EmptyCache = true with get,set + member val Benchmark = Unchecked.defaultof<_> with get, set member this.setup(project) = @@ -29,6 +32,12 @@ type ComputationExpressionBenchmarks() = this.Benchmark <- ProjectWorkflowBuilder(project, checker = checker).CreateBenchmarkBuilder() saveProject project false checker |> Async.RunSynchronously + [] + member this.StartIteration() = + if this.EmptyCache then + this.Benchmark.Checker.InvalidateAll() + this.Benchmark.Checker.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() + [] member this.SetupWithSource() = this.setup diff --git a/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ce/CE1xnest15.fs b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ce/CE1xnest15.fs new file mode 100644 index 00000000000..13e44372f92 --- /dev/null +++ b/tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ce/CE1xnest15.fs @@ -0,0 +1,55 @@ +module Test = + + + type MyBuilder() = + member x.Zero() : float = 0.0 + member x.Yield(a : float) = a + member x.Delay(l : unit -> float) = l() + member x.Combine(l : float, r : float) = l+r + + let my = MyBuilder() + + let a() = + my { + my { + my { + 1 + my { + + my { + 3.0 + my { + 1.0 + my { + 2.0 + my { + 1.0 + 2.0 + my { + my { + my { + my { + 3.0 + my { + 3.0 + my { + 1.0 + my { + my { + 1.0 + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } \ No newline at end of file From 04dc4b372be1d83a86d05e7655090090e9582ccd Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Fri, 26 Apr 2024 21:36:20 +0200 Subject: [PATCH 3/9] release notes --- docs/release-notes/.FSharp.Compiler.Service/8.0.400.md | 1 + 1 file changed, 1 insertion(+) diff --git a/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md b/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md index 674a2ec7d47..e89d10df86e 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md +++ b/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md @@ -9,6 +9,7 @@ * Fix bug in optimization of for-loops over integral ranges with steps and units of measure. ([Issue #17025](https://github.com/dotnet/fsharp/issues/17025), [PR #17040](https://github.com/dotnet/fsharp/pull/17040), [PR #17048](https://github.com/dotnet/fsharp/pull/17048)) * Fix calling an overridden virtual static method via the interface ([PR #17013](https://github.com/dotnet/fsharp/pull/17013)) * Fix state machines compilation, when big decision trees are involved, by removing code split when resumable code is detected ([PR #17076](https://github.com/dotnet/fsharp/pull/17076)) +* Fix for exponential runtime in CE builders when using nested implicit yields [PR #17096](https://github.com/dotnet/fsharp/pull/17096) ### Added From 9b117be8e84236827734b84a984b44761e335042 Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Mon, 29 Apr 2024 09:44:15 +0200 Subject: [PATCH 4/9] fixed cache-hit lookup for implicit yields (missed unification) --- src/Compiler/Checking/CheckBasics.fs | 2 +- src/Compiler/Checking/CheckBasics.fsi | 2 +- src/Compiler/Checking/CheckExpressions.fs | 14 +++++++++----- 3 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index b5ed3f8b6c0..a7d99dbe2f9 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -246,7 +246,7 @@ type TcEnv = // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : list + eCachedImplicitYieldExpressions : list } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index eeff25f5740..0e0e2ac178a 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -131,7 +131,7 @@ type TcEnv = // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : list + eCachedImplicitYieldExpressions : list } member DisplayEnv: DisplayEnv diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 44582d5a703..d2e85d57520 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5336,8 +5336,9 @@ and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let g = cenv.g - match env.eCachedImplicitYieldExpressions |> List.tryPick (fun (se, e) -> if System.Object.ReferenceEquals(se, synExpr) then Some e else None) with - | Some expr -> + match env.eCachedImplicitYieldExpressions |> List.tryPick (fun (se, ty, e) -> if System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None) with + | Some (ty, expr) -> + UnifyOverallType cenv env range0 overallTy ty expr, tpenv | _ -> @@ -6170,9 +6171,12 @@ and TcExprSequential (cenv: cenv) overallTy env tpenv (synExpr, _sp, dir, synExp and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExpr1, synExpr2, otherExpr, m) = - let isStmt, expr1, tpenv = + let isStmt, expr1, expr1Ty, tpenv = let env1 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } - TryTcStmt cenv env1 tpenv synExpr1 + let expr, ty, tpenv = TcExprOfUnknownType cenv env1 tpenv synExpr1 + let m = synExpr1.Range + let hasTypeUnit = TryUnifyUnitTypeWithoutWarning cenv env m ty + hasTypeUnit, expr, ty, tpenv if isStmt then let env2 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressStmt -> true | _ -> false) } @@ -6188,7 +6192,7 @@ and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExp | Expr.DebugPoint(_,e) -> e | _ -> expr1 - let newEnv = { env with eCachedImplicitYieldExpressions = (synExpr1, cachedExpr) :: env.eCachedImplicitYieldExpressions } + let newEnv = { env with eCachedImplicitYieldExpressions = (synExpr1, expr1Ty, cachedExpr) :: env.eCachedImplicitYieldExpressions } TcExpr cenv overallTy newEnv tpenv otherExpr and TcExprStaticOptimization (cenv: cenv) overallTy env tpenv (constraints, synExpr2, expr3, m) = From 0fdc142bff30b811d578b11026aaf1425c53eeff Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Mon, 29 Apr 2024 12:41:36 +0200 Subject: [PATCH 5/9] * HashMultiMap for more efficient cache lookup in implicit-yield cached expressions * added TType return to TryTcStmt --- src/Compiler/Checking/CheckBasics.fs | 3 ++- src/Compiler/Checking/CheckBasics.fsi | 3 ++- .../Checking/CheckComputationExpressions.fs | 2 +- src/Compiler/Checking/CheckDeclarations.fs | 2 +- src/Compiler/Checking/CheckExpressions.fs | 23 +++++++++++-------- src/Compiler/Checking/CheckExpressions.fsi | 2 +- 6 files changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index a7d99dbe2f9..61b4b835c6f 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -8,6 +8,7 @@ open System.Collections.Generic open FSharp.Compiler.Diagnostics open Internal.Utilities.Library open Internal.Utilities.Library.Extras +open Internal.Utilities.Collections open FSharp.Compiler open FSharp.Compiler.AccessibilityLogic open FSharp.Compiler.CompilerGlobalState @@ -246,7 +247,7 @@ type TcEnv = // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : list + eCachedImplicitYieldExpressions : HashMultiMap } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index 0e0e2ac178a..70831ad2959 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -6,6 +6,7 @@ open System.Collections.Concurrent open System.Collections.Generic open FSharp.Compiler.Diagnostics open Internal.Utilities.Library +open Internal.Utilities.Collections open FSharp.Compiler.AccessibilityLogic open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.ConstraintSolver @@ -131,7 +132,7 @@ type TcEnv = // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : list + eCachedImplicitYieldExpressions : HashMultiMap } member DisplayEnv: DisplayEnv diff --git a/src/Compiler/Checking/CheckComputationExpressions.fs b/src/Compiler/Checking/CheckComputationExpressions.fs index 2aa454f9508..fa56149ac7f 100644 --- a/src/Compiler/Checking/CheckComputationExpressions.fs +++ b/src/Compiler/Checking/CheckComputationExpressions.fs @@ -3405,7 +3405,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = } if enableImplicitYield then - let hasTypeUnit, expr, tpenv = TryTcStmt cenv env tpenv comp + let hasTypeUnit, _ty, expr, tpenv = TryTcStmt cenv env tpenv comp if hasTypeUnit then Choice2Of2 expr, tpenv diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index e96ba45b23b..1736132abe8 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5537,7 +5537,7 @@ let emptyTcEnv g = eCallerMemberName = None eLambdaArgInfos = [] eIsControlFlow = false - eCachedImplicitYieldExpressions = [] } + eCachedImplicitYieldExpressions = HashMultiMap(HashIdentity.Structural) } let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) = (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index d2e85d57520..c6c6b1841ac 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5299,7 +5299,7 @@ and TryTcStmt (cenv: cenv) env tpenv synExpr = let expr, ty, tpenv = TcExprOfUnknownType cenv env tpenv synExpr let m = synExpr.Range let hasTypeUnit = TryUnifyUnitTypeWithoutWarning cenv env m ty - hasTypeUnit, expr, tpenv + hasTypeUnit, ty, expr, tpenv and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg: SynExpr) = let g = cenv.g @@ -5336,7 +5336,14 @@ and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let g = cenv.g - match env.eCachedImplicitYieldExpressions |> List.tryPick (fun (se, ty, e) -> if System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None) with + let cachedExpression = + match env.eCachedImplicitYieldExpressions.TryFind synExpr.Range with + | Some (se, ty, e) -> + if System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None + | None -> + None + + match cachedExpression with | Some (ty, expr) -> UnifyOverallType cenv env range0 overallTy ty expr, tpenv @@ -6171,12 +6178,9 @@ and TcExprSequential (cenv: cenv) overallTy env tpenv (synExpr, _sp, dir, synExp and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExpr1, synExpr2, otherExpr, m) = - let isStmt, expr1, expr1Ty, tpenv = + let isStmt, expr1Ty, expr1, tpenv = let env1 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } - let expr, ty, tpenv = TcExprOfUnknownType cenv env1 tpenv synExpr1 - let m = synExpr1.Range - let hasTypeUnit = TryUnifyUnitTypeWithoutWarning cenv env m ty - hasTypeUnit, expr, ty, tpenv + TryTcStmt cenv env1 tpenv synExpr1 if isStmt then let env2 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressStmt -> true | _ -> false) } @@ -6192,8 +6196,9 @@ and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExp | Expr.DebugPoint(_,e) -> e | _ -> expr1 - let newEnv = { env with eCachedImplicitYieldExpressions = (synExpr1, expr1Ty, cachedExpr) :: env.eCachedImplicitYieldExpressions } - TcExpr cenv overallTy newEnv tpenv otherExpr + env.eCachedImplicitYieldExpressions.Add(synExpr1.Range, (synExpr1, expr1Ty, cachedExpr)) + try TcExpr cenv overallTy env tpenv otherExpr + finally env.eCachedImplicitYieldExpressions.Remove synExpr1.Range and TcExprStaticOptimization (cenv: cenv) overallTy env tpenv (constraints, synExpr2, expr3, m) = let constraintsR, tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index cc136eba754..df00889f795 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -701,7 +701,7 @@ val TcLinearExprs: /// Try to check a syntactic statement and indicate if it's type is not unit without emitting a warning val TryTcStmt: - cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> synExpr: SynExpr -> bool * Expr * UnscopedTyparEnv + cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> synExpr: SynExpr -> bool * TType * Expr * UnscopedTyparEnv /// Check a pattern being used as a pattern match val TcMatchPattern: From 852bd07a490d5f2ffceddf55b63120f8b8a8ede6 Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Mon, 29 Apr 2024 13:17:04 +0200 Subject: [PATCH 6/9] * used `FindAll` in eCachedImplicitYieldExpressions lookup for handling duplicated ranges of implicitly yielded expressions --- src/Compiler/Checking/CheckExpressions.fs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index c6c6b1841ac..75146fde06f 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5337,11 +5337,10 @@ and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let g = cenv.g let cachedExpression = - match env.eCachedImplicitYieldExpressions.TryFind synExpr.Range with - | Some (se, ty, e) -> + env.eCachedImplicitYieldExpressions.FindAll synExpr.Range + |> List.tryPick (fun (se, ty, e) -> if System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None - | None -> - None + ) match cachedExpression with | Some (ty, expr) -> From b2506f4ea7910725f209633c0f976690b358b3d7 Mon Sep 17 00:00:00 2001 From: Georg Haaser Date: Mon, 29 Apr 2024 13:22:49 +0200 Subject: [PATCH 7/9] Update src/Compiler/Checking/CheckExpressions.fs Co-authored-by: Vlad Zarytovskii --- src/Compiler/Checking/CheckExpressions.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 75146fde06f..34d7ed7312b 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5339,7 +5339,7 @@ and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let cachedExpression = env.eCachedImplicitYieldExpressions.FindAll synExpr.Range |> List.tryPick (fun (se, ty, e) -> - if System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None + if obj.ReferenceEquals(se, synExpr) then Some (ty, e) else None ) match cachedExpression with From f1a3b66a8a786f8bbd082d1b04405049f16de34e Mon Sep 17 00:00:00 2001 From: krauthaufen Date: Thu, 2 May 2024 10:02:18 +0200 Subject: [PATCH 8/9] fixed range in TypeChecker for implicitly-yielded values --- src/Compiler/Checking/CheckExpressions.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 34d7ed7312b..2c7a80a3a1d 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5344,7 +5344,7 @@ and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = match cachedExpression with | Some (ty, expr) -> - UnifyOverallType cenv env range0 overallTy ty + UnifyOverallType cenv env synExpr.Range overallTy ty expr, tpenv | _ -> From ed377f643b9744b271387cf3a12dfa89b5deda84 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 2 May 2024 12:25:16 +0000 Subject: [PATCH 9/9] Automated command ran: fantomas Co-authored-by: krauthaufen <6370801+krauthaufen@users.noreply.github.com> --- src/Compiler/Checking/CheckBasics.fsi | 4 ++-- src/Compiler/Checking/CheckExpressions.fsi | 6 +++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index 70831ad2959..a71aa08effb 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -129,10 +129,10 @@ type TcEnv = eLambdaArgInfos: ArgReprInfo list list eIsControlFlow: bool - + // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : HashMultiMap + eCachedImplicitYieldExpressions: HashMultiMap } member DisplayEnv: DisplayEnv diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi index df00889f795..40ac1cd20bd 100644 --- a/src/Compiler/Checking/CheckExpressions.fsi +++ b/src/Compiler/Checking/CheckExpressions.fsi @@ -701,7 +701,11 @@ val TcLinearExprs: /// Try to check a syntactic statement and indicate if it's type is not unit without emitting a warning val TryTcStmt: - cenv: TcFileState -> env: TcEnv -> tpenv: UnscopedTyparEnv -> synExpr: SynExpr -> bool * TType * Expr * UnscopedTyparEnv + cenv: TcFileState -> + env: TcEnv -> + tpenv: UnscopedTyparEnv -> + synExpr: SynExpr -> + bool * TType * Expr * UnscopedTyparEnv /// Check a pattern being used as a pattern match val TcMatchPattern: