Use new Cache api in various places

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

src/Compiler/Checking/TypeRelations.fs

@@ -25,16 +25,16 @@ type CanCoerce =
     | CanCoerce
     | NoCoerce
 
+let tryGetTypeStructure ty =
+    match ty with
+    | TType_app _ ->
+        tryGetTypeStructureOfStrippedType ty
+    | _ -> ValueNone
+
 [<Struct; NoComparison>]
 type TTypeCacheKey =
     | TTypeCacheKey of TypeStructure * TypeStructure * CanCoerce
     static member TryGetFromStrippedTypes(ty1, ty2, canCoerce) =
-        let tryGetTypeStructure ty =
-            match ty with
-            | TType_app _ ->
-                tryGetTypeStructureOfStrippedType ty
-            | _ -> ValueNone
-
         (tryGetTypeStructure ty1, tryGetTypeStructure ty2)
         ||> ValueOption.map2(fun t1 t2 -> TTypeCacheKey(t1, t2, canCoerce))
 
@@ -45,7 +45,44 @@ let getTypeSubsumptionCache =
             | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction
             | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 }
         new Caches.Cache<TTypeCacheKey, bool>(options, "typeSubsumptionCache")
-    Extras.WeakMap.getOrCreate factory     
+    Extras.WeakMap.getOrCreate factory  
+
+// Cache for feasible equivalence checks
+[<Struct; NoComparison>]
+type TTypeFeasibleEquivCacheKey =
+    | TTypeFeasibleEquivCacheKey of TypeStructure * TypeStructure * bool
+    static member TryGetFromStrippedTypes(stripMeasures: bool, ty1: TType, ty2: TType) =
+        let sortPair a b = if hash a <= hash b then (a, b) else (b, a)
+        (tryGetTypeStructure ty1, tryGetTypeStructure ty2)
+        ||> ValueOption.map2(fun t1 t2 ->
+            let t1, t2 = sortPair t1 t2
+            TTypeFeasibleEquivCacheKey(t1, t2, 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 TryGetFromStrippedTypes(ty1: TType, ty2: TType) =
+        (tryGetTypeStructure ty1, tryGetTypeStructure ty2)
+        ||> ValueOption.map2(fun t1 t2 -> TTypeDefinitelySubsumesNoCoerceCacheKey(t1, t2))
+
+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.
@@ -64,22 +101,37 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =
     if ty1 === ty2 then true
     elif typeEquiv g ty1 ty2 then true
     else
+
+        let checkSubsumes ty1 ty2 = 
+
+            typeEquiv g ty1 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 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))))
+        if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
+            let key = TTypeDefinitelySubsumesNoCoerceCacheKey.TryGetFromStrippedTypes(ty1, ty2)
+            match key with
+            | ValueNone -> checkSubsumes ty1 ty2
+            | ValueSome key ->
+                (getTypeDefinitelySubsumesNoCoerceCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2)
+        else
+            checkSubsumes ty1 ty2
 
 let stripAll stripMeasures g ty =
     if stripMeasures then
@@ -96,30 +148,40 @@ 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 key = TTypeFeasibleEquivCacheKey.TryGetFromStrippedTypes(stripMeasures, ty1, ty2)
+        match key with
+        | ValueNone -> computeEquiv ty1 ty2
+        | ValueSome key1 ->(getTypeFeasibleEquivCache g).GetOrAdd(key1, fun _ -> computeEquiv ty1 ty2)
+    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

@@ -505,7 +505,7 @@ module StructuralUtilities =
             | TType_measure m -> yield! emitMeasure m
         }
 
-    let private getTypeStructureOfStrippedType (ty: TType) =
+    let private getTypeStructureOfStrippedTypeUncached (ty: TType) =
 
         let env =
             {
@@ -522,14 +522,14 @@ module StructuralUtilities =
         else Stable tokens
 
     // Speed up repeated calls by memoizing results for types that yield a stable structure.
-    let private memoize =
+    let private getTypeStructureOfStrippedType =
         WeakMap.cacheConditionally
             (function
             | Stable _ -> true
             | _ -> false)
-            getTypeStructureOfStrippedType
+            getTypeStructureOfStrippedTypeUncached
 
     let tryGetTypeStructureOfStrippedType ty =
-        match memoize ty with
+        match getTypeStructureOfStrippedType ty with
         | PossiblyInfinite -> ValueNone
         | ts -> ValueSome ts

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>