Implicit yield performance fix

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
 

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<range, SynExpr * TType * Expr>
     }
 
     member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv

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<range, SynExpr * TType * Expr>
     }
 
     member DisplayEnv: DisplayEnv

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

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

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
@@ -5335,100 +5335,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 System.Object.ReferenceEquals(se, synExpr) then Some (ty, e) else None
+        )
+
+    match cachedExpression with
+    | Some (ty, expr) ->
+        UnifyOverallType cenv env range0 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<tyargs>
-    | 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<tyargs>
+        | 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
@@ -6164,7 +6177,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
 
@@ -6177,7 +6190,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

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:

tests/benchmarks/FCSBenchmarks/CompilerServiceBenchmarks/ComputationExpressionBenchmarks.fs

@@ -11,24 +11,33 @@ open FSharp.Benchmarks.Common.Categories
 type ComputationExpressionBenchmarks() =
 
     let mutable sourceFileName = ""
-
     [<Params("CE100xnest1.fs",
              "CE100xnest5.fs",
-             // "CE100xnest10.fs", // enable if you have the spare time
+             "CE1xnest15.fs",
+             // "CE100xnest10.fs" // enable if you have the spare time
              "CE200xnest5.fs",
              "CEwCO500xnest1.fs",
              "CEwCO100xnest5.fs")>]
     member public this.Source
         with get () = File.ReadAllText(__SOURCE_DIRECTORY__ ++ "ce" ++ sourceFileName)
         and set f = sourceFileName <- f
 
+    [<ParamsAllValues>]
+    member val EmptyCache = true with get,set
+
     member val Benchmark = Unchecked.defaultof<_> with get, set
 
     member this.setup(project) =
         let checker = FSharpChecker.Create()
         this.Benchmark <- ProjectWorkflowBuilder(project, checker = checker).CreateBenchmarkBuilder()
         saveProject project false checker |> Async.RunSynchronously
 
+    [<IterationSetup(Targets = [| "CheckCE"; "CompileCE" |])>]
+    member this.StartIteration() =
+        if this.EmptyCache then
+            this.Benchmark.Checker.InvalidateAll()
+            this.Benchmark.Checker.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients()
+
     [<GlobalSetup(Targets = [| "CheckCE"; "CompileCE" |])>]
     member this.SetupWithSource() =
         this.setup

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