the rest rebased

Author: majocha

src/Compiler/Checking/CheckBasics.fs

@@ -235,11 +235,7 @@ type TcEnv =
       eLambdaArgInfos: ArgReprInfo list list
 
       // 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>
+      eIsControlFlow: bool     
     }
 
     member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv
@@ -311,8 +307,6 @@ type TcFileState =
 
       diagnosticOptions: FSharpDiagnosticOptions
 
-      argInfoCache: ConcurrentDictionary<string * range, ArgReprInfo>
-
       // forward call
       TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv
 
@@ -362,7 +356,6 @@ type TcFileState =
           conditionalDefines = conditionalDefines
           isInternalTestSpanStackReferring = isInternalTestSpanStackReferring
           diagnosticOptions = diagnosticOptions
-          argInfoCache = ConcurrentDictionary()
           TcPat = tcPat
           TcSimplePats = tcSimplePats
           TcSequenceExpressionEntry = tcSequenceExpressionEntry

src/Compiler/Checking/CheckBasics.fsi

@@ -130,9 +130,6 @@ type TcEnv =
 
         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
@@ -269,11 +266,6 @@ type TcFileState =
 
         diagnosticOptions: FSharpDiagnosticOptions
 
-        /// A cache for ArgReprInfos which get created multiple times for the same values
-        /// Since they need to be later mutated with updates from signature files this should make sure
-        /// we're always dealing with the same instance and the updates don't get lost
-        argInfoCache: ConcurrentDictionary<string * range, ArgReprInfo>
-
         // forward call
         TcPat:
             WarnOnUpperFlag

src/Compiler/Checking/CheckDeclarations.fs

@@ -5609,8 +5609,7 @@ let emptyTcEnv g =
       eCtorInfo = None
       eCallerMemberName = None 
       eLambdaArgInfos = []
-      eIsControlFlow = false
-      eCachedImplicitYieldExpressions = HashMultiMap(HashIdentity.Structural, useConcurrentDictionary = true) }
+      eIsControlFlow = false }
 
 let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) =
     (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> 

src/Compiler/Checking/Expressions/CheckExpressions.fs

@@ -958,6 +958,10 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData, retData) as sigMD) =
     | _ ->
         sigMD
 
+let getArgInfoCache =
+    let options = Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction
+    let factory _ = new Caches.Cache<_, ArgReprInfo>(options, "argInfoCache")
+    WeakMap.getOrCreate factory
 
 let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attributes attrs, isOpt, nm)) =
     // Synthesize an artificial "OptionalArgument" attribute for the parameter
@@ -982,18 +986,12 @@ let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attribu
 
     let key = nm |> Option.map (fun id -> id.idText, id.idRange)
 
+    let mkDefaultArgInfo _ : ArgReprInfo = { Attribs = attribs; Name = nm; OtherRange = None }
+
     let argInfo =
-        key
-        |> Option.map cenv.argInfoCache.TryGetValue
-        |> Option.bind (fun (found, info) ->
-            if found then
-                Some info
-            else None)
-        |> Option.defaultValue ({ Attribs = attribs; Name = nm; OtherRange = None }: ArgReprInfo)
-
-    match key with
-    | Some k -> cenv.argInfoCache.[k] <- argInfo
-    | None -> ()
+        match key with
+        | Some key -> (getArgInfoCache cenv).GetOrAdd(key, mkDefaultArgInfo)
+        | _ -> mkDefaultArgInfo ()
 
     // Set freshly computed attribs in case they are different in the cache
     argInfo.Attribs <- attribs
@@ -4054,6 +4052,13 @@ type ImplicitlyBoundTyparsAllowed =
     | NewTyparsOK
     | NoNewTypars
 
+// 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.
+let getImplicitYieldExpressionsCache =
+    let options = Caches.CacheOptions.getReferenceIdentity() |> Caches.CacheOptions.withNoEviction
+    let factory _ = new Caches.Cache<SynExpr, _>(options, "implicitYieldExpressions")
+    WeakMap.getOrCreate factory 
+
 //-------------------------------------------------------------------------
 // Checking types and type constraints
 //-------------------------------------------------------------------------
@@ -5508,19 +5513,12 @@ and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg
 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) ->
+    match (getImplicitYieldExpressionsCache cenv).TryGetValue synExpr with
+    | true, (ty, expr) ->
         UnifyOverallType cenv env synExpr.Range overallTy ty
         expr, tpenv
     | _ ->
 
-
         match synExpr with
 
         // A.
@@ -6382,9 +6380,8 @@ and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExp
             | 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
+        (getImplicitYieldExpressionsCache cenv).AddOrUpdate(synExpr1, (expr1Ty, cachedExpr))
+        TcExpr cenv overallTy env tpenv otherExpr
 
 and TcExprStaticOptimization (cenv: cenv) overallTy env tpenv (constraints, synExpr2, expr3, m) =
     let constraintsR, tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints

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

@@ -353,6 +353,7 @@
     <Compile Include="FSharpChecker\TransparentCompiler.fs" />
     <Compile Include="FSharpChecker\SymbolUse.fs" />
     <Compile Include="FSharpChecker\FindReferences.fs" />
+    <Compile Include="Optimizer\NestedApplications.fs" />
     <Compile Include="Attributes\AttributeCtorSetPropAccess.fs" />
   </ItemGroup>
 

tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs

@@ -0,0 +1,64 @@
+namespace FSharp.Compiler.ComponentTests.Optimizer
+
+open System.Text
+open Xunit
+open FSharp.Test
+open FSharp.Test.Compiler
+open FSharp.Test.Utilities
+
+module private Gen =
+    let nestedLetApps depth =
+        // Builds: let v1 = id 0 in let v2 = id v1 in ... in ignore vN
+        let sb = StringBuilder()
+        sb.AppendLine("module M")       |> ignore
+        sb.AppendLine("let id x = x")   |> ignore
+        sb.AppendLine("let run () =")   |> ignore
+        for i in 1 .. depth do
+            if i = 1 then
+                sb.Append("    let v1 = id 0") |> ignore
+            else
+                sb.Append(" in let v").Append(i).Append(" = id v").Append(i-1) |> ignore
+        sb.AppendLine(" in ()") |> ignore
+        sb.ToString()
+
+    let nestedDirectApps depth =
+        // Builds: let res = id(id(id(...(0)))) in ignore res
+        let sb = StringBuilder()
+        sb.AppendLine("module N")       |> ignore
+        sb.AppendLine("let id x = x")   |> ignore
+        sb.Append("let run () = let res = ") |> ignore
+        for _ in 1 .. depth do
+            sb.Append("id (") |> ignore
+        sb.Append("0") |> ignore
+        for _ in 1 .. depth do
+            sb.Append(")")   |> ignore
+        sb.AppendLine(" in ignore res") |> ignore
+        sb.ToString()
+
+[<Collection(nameof NotThreadSafeResourceCollection)>]
+type ``Nested application optimizer``() =
+
+    // Moderate depths to keep CI stable while still exercising the quadratic shapes
+    [<Theory>]
+    [<InlineData(100)>]
+    [<InlineData(1000)>]
+    let ``let-chains of nested apps compile under --optimize+`` depth =
+        let src = Gen.nestedLetApps depth
+        FSharp src
+        |> withOptions [ "--optimize+"; "--times" ]
+        |> asExe
+        |> ignoreWarnings
+        |> compile
+        |> shouldSucceed
+
+    [<Theory>]
+    [<InlineData(100)>]
+    [<InlineData(1000)>]
+    let ``direct nested application compiles under --optimize+`` depth =
+        let src = Gen.nestedDirectApps depth
+        FSharp src
+        |> withOptions [ "--optimize+"; "--times" ]
+        |> asExe
+        |> ignoreWarnings
+        |> compile
+        |> shouldSucceed