Use new Cache api in various places

src/Compiler/Checking/CheckBasics.fs

@@ -243,11 +243,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
@@ -319,8 +315,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
 
@@ -370,7 +364,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

@@ -5618,8 +5618,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,8 +958,12 @@ 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)) =
+let TranslateTopArgSynInfo cenv isArg m tcAttributes (SynArgInfo(Attributes attrs, isOpt, nm)) =
     // Synthesize an artificial "OptionalArgument" attribute for the parameter
     let optAttrs =
         if isOpt then
@@ -980,20 +984,14 @@ let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attribu
     // Call the attribute checking function
     let attribs = tcAttributes (optAttrs@attrs)
 
-    let key = nm |> Option.map (fun id -> id.idText, id.idRange)
+    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.
@@ -6384,9 +6382,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

src/Compiler/Checking/TypeRelations.fs

@@ -40,6 +40,38 @@ let getTypeSubsumptionCache =
         new Caches.Cache<TTypeCacheKey, bool>(options, "typeSubsumptionCache")
     Extras.WeakMap.getOrCreate factory     
 
+// Cache for feasible equivalence checks
+[<Struct; NoComparison>]
+type TTypeFeasibleEquivCacheKey =
+    | TTypeFeasibleEquivCacheKey of TypeStructure * TypeStructure * bool
+    static member FromStrippedTypes(stripMeasures: bool, ty1: TType, ty2: TType) =
+        TTypeFeasibleEquivCacheKey(getTypeStructure ty1, getTypeStructure ty2, stripMeasures)
+
+let getTypeFeasibleEquivCache =
+    let factory (g: TcGlobals) =
+        let options =
+            match g.compilationMode with
+            | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction
+            | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 }
+        new Caches.Cache<TTypeFeasibleEquivCacheKey, bool>(options, "typeFeasibleEquivCache")
+    Extras.WeakMap.getOrCreate factory
+
+// Cache for definite subsumption without coercion
+[<Struct; NoComparison>]
+type TTypeDefinitelySubsumesNoCoerceCacheKey =
+    | TTypeDefinitelySubsumesNoCoerceCacheKey of TypeStructure * TypeStructure
+    static member FromStrippedTypes(ty1: TType, ty2: TType) =
+        TTypeDefinitelySubsumesNoCoerceCacheKey(getTypeStructure ty1, getTypeStructure ty2)
+
+let getTypeDefinitelySubsumesNoCoerceCache =
+    let factory (g: TcGlobals) =
+        let options =
+            match g.compilationMode with
+            | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction
+            | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 }
+        new Caches.Cache<TTypeDefinitelySubsumesNoCoerceCacheKey, bool>(options, "typeDefinitelySubsumesNoCoerceCache")
+    Extras.WeakMap.getOrCreate factory
+
 /// Implements a :> b without coercion based on finalized (no type variable) types
 // Note: This relation is approximate and not part of the language specification.
 //
@@ -59,20 +91,28 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =
     else
         let ty1 = stripTyEqns g ty1
         let ty2 = stripTyEqns g ty2
-        // F# reference types are subtypes of type 'obj'
-        (typeEquiv g ty1 g.obj_ty_ambivalent && isRefTy g ty2) ||
-        // Follow the supertype chain
-        (isAppTy g ty2 &&
-        isRefTy g ty2 &&
 
-        ((match GetSuperTypeOfType g amap m ty2 with
-            | None -> false
-            | Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) ||
-
-        // Follow the interface hierarchy
-        (isInterfaceTy g ty1 &&
-            ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m
-                |> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1))))
+        let checkSubsumes () =
+            // F# reference types are subtypes of type 'obj'
+            (typeEquiv g ty1 g.obj_ty_ambivalent && isRefTy g ty2) ||
+            // Follow the supertype chain
+            (isAppTy g ty2 &&
+            isRefTy g ty2 &&
+
+            ((match GetSuperTypeOfType g amap m ty2 with
+                | None -> false
+                | Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) ||
+
+            // Follow the interface hierarchy
+            (isInterfaceTy g ty1 &&
+                ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m
+                    |> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1))))
+
+        if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
+            let key = TTypeDefinitelySubsumesNoCoerceCacheKey.FromStrippedTypes(ty1, ty2)
+            (getTypeDefinitelySubsumesNoCoerceCache g).GetOrAdd(key, fun _ -> checkSubsumes ())
+        else
+            checkSubsumes ()
 
 let stripAll stripMeasures g ty =
     if stripMeasures then
@@ -89,30 +129,42 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 =
     let ty1 = stripAll stripMeasures g ty1
     let ty2 = stripAll stripMeasures g ty2
 
-    match ty1, ty2 with
-    | TType_measure _, TType_measure _
-    | TType_var _, _
-    | _, TType_var _ -> true
+    let computeEquiv ty1 ty2 =
+        match ty1, ty2 with
+        | TType_measure _, TType_measure _
+        | TType_var _, _
+        | _, TType_var _ -> true
+
+        | TType_app (tcref1, l1, _), TType_app (tcref2, l2, _) when tyconRefEq g tcref1 tcref2 ->
+            List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
 
-    | TType_app (tcref1, l1, _), TType_app (tcref2, l2, _) when tyconRefEq g tcref1 tcref2 ->
-        List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
+        | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) ->
+            (evalTupInfoIsStruct anonInfo1.TupInfo = evalTupInfoIsStruct anonInfo2.TupInfo) &&
+            (match anonInfo1.Assembly, anonInfo2.Assembly with ccu1, ccu2 -> ccuEq ccu1 ccu2) &&
+            (anonInfo1.SortedNames = anonInfo2.SortedNames) &&
+            List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
 
-    | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) ->
-        (evalTupInfoIsStruct anonInfo1.TupInfo = evalTupInfoIsStruct anonInfo2.TupInfo) &&
-        (match anonInfo1.Assembly, anonInfo2.Assembly with ccu1, ccu2 -> ccuEq ccu1 ccu2) &&
-        (anonInfo1.SortedNames = anonInfo2.SortedNames) &&
-        List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
+        | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) ->
+            evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
+            List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
 
-    | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) ->
-        evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
-        List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
+        | TType_fun (domainTy1, rangeTy1, _), TType_fun (domainTy2, rangeTy2, _) ->
+            TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 &&
+            TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2
 
-    | TType_fun (domainTy1, rangeTy1, _), TType_fun (domainTy2, rangeTy2, _) ->
-        TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 &&
-        TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2
+        | _ ->
+            false
 
-    | _ ->
-        false
+    if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
+        let cache = getTypeFeasibleEquivCache g
+        let key1 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty1, ty2)
+        let res = cache.GetOrAdd(key1, fun _ -> computeEquiv ty1 ty2)
+        // Cache the symmetric result as well since this relation is symmetric
+        let key2 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty2, ty1)
+        cache.GetOrAdd(key2, fun _ -> res) |> ignore
+        res
+    else
+        computeEquiv ty1 ty2
 
 /// The feasible equivalence relation. Part of the language spec.
 let TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =

src/Compiler/Utilities/TypeHashing.fs

@@ -10,6 +10,7 @@ open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
 open System.Collections.Immutable
+open System
 
 type ObserverVisibility =
     | PublicOnly
@@ -382,7 +383,7 @@ module StructuralUtilities =
     [<Struct; CustomEquality; NoComparison>]
     type NeverEqual =
         struct
-            interface System.IEquatable<NeverEqual> with
+            interface IEquatable<NeverEqual> with
                 member _.Equals _ = false
 
             override _.Equals _ = false

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

@@ -351,6 +351,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

tests/FSharp.Test.Utilities/XunitHelpers.fs

@@ -195,6 +195,8 @@ type OpenTelemetryExport(testRunName, enable) =
 // However, we want to ensure that OneTimeSetup is called only once per test run.
 module OneTimeSetup =
 
+    open System.Threading
+
     let init =
         lazy
     #if !NETCOREAPP