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 e4f784a1045..4203d7f41f8 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md +++ b/docs/release-notes/.FSharp.Compiler.Service/8.0.400.md @@ -10,6 +10,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 diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index bbfa5557b2d..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 @@ -243,6 +244,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 : HashMultiMap } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index e3ad581cb61..a71aa08effb 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 @@ -128,6 +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 } 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 4ecd8f4824a..1736132abe8 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 = 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 5d42f2fd416..ec2b29d08be 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -5354,7 +5354,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 @@ -5390,100 +5390,113 @@ 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 + + let cachedExpression = + env.eCachedImplicitYieldExpressions.FindAll synExpr.Range + |> List.tryPick (fun (se, ty, e) -> + if obj.ReferenceEquals(se, synExpr) then Some (ty, e) else None + ) + + match cachedExpression with + | Some (ty, expr) -> + UnifyOverallType cenv env synExpr.Range overallTy ty + 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 @@ -6219,7 +6232,7 @@ 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, expr1Ty, expr1, tpenv = let env1 = { env with eIsControlFlow = (match sp with DebugPointAtSequential.SuppressNeither | DebugPointAtSequential.SuppressExpr -> true | _ -> false) } TryTcStmt cenv env1 tpenv synExpr1 @@ -6232,7 +6245,14 @@ 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 + + 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..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 * 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: 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