use new cache api

Author: majocha

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

@@ -5620,8 +5620,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

@@ -955,8 +955,12 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData, retData) as sigMD) =
     | _ ->
         sigMD
 
+let getArgInfoCache =
+    let options = Caches.CacheOptions.getDefault() |> 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
@@ -977,20 +981,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
@@ -4051,6 +4049,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
 //-------------------------------------------------------------------------
@@ -5503,19 +5508,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.
@@ -6378,9 +6376,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

@@ -7,6 +7,7 @@ module internal FSharp.Compiler.TypeRelations
 open FSharp.Compiler.Features
 open Internal.Utilities.Collections
 open Internal.Utilities.Library
+open Internal.Utilities.TypeHashing
 
 open FSharp.Compiler.DiagnosticsLogger
 open FSharp.Compiler.TcGlobals
@@ -19,6 +20,55 @@ open Import
 
 #nowarn "3391"
 
+[<Struct; NoComparison>]
+type CanCoerce =
+    | CanCoerce
+    | NoCoerce
+
+[<Struct; NoComparison; CustomEquality; System.Diagnostics.DebuggerDisplay("{ToString()}")>]
+type TTypeCacheKey =
+
+    val ty1: TType
+    val ty2: TType
+    val canCoerce: CanCoerce
+
+    private new (ty1, ty2, canCoerce) =
+        { ty1 = ty1; ty2 = ty2; canCoerce = canCoerce }
+
+    static member FromStrippedTypes (ty1, ty2, canCoerce) =
+        TTypeCacheKey(ty1, ty2, canCoerce)
+
+    interface System.IEquatable<TTypeCacheKey> with
+        member this.Equals other =
+            if this.canCoerce <> other.canCoerce then
+                false
+            elif this.ty1 === other.ty1 && this.ty2 === other.ty2 then
+                true
+            else
+                HashStamps.stampEquals this.ty1 other.ty1
+                && HashStamps.stampEquals this.ty2 other.ty2
+
+    override this.Equals(other:objnull) =
+        match other with
+        | :? TTypeCacheKey as p -> (this :> System.IEquatable<TTypeCacheKey>).Equals p
+        | _ -> false
+
+    override this.GetHashCode () : int =
+        HashStamps.hashTType this.ty1
+        |> pipeToHash (HashStamps.hashTType this.ty2)
+        |> pipeToHash (hash this.canCoerce)
+
+    override this.ToString () = $"{this.ty1.DebugText}-{this.ty2.DebugText}"
+
+let getTypeSubsumptionCache =
+    let factory (g: TcGlobals) =
+        let options =
+            match g.compilationMode with
+            | CompilationMode.OneOff -> Caches.CacheOptions.getDefault() |> Caches.CacheOptions.withNoEviction
+            | _ -> { Caches.CacheOptions.getDefault() with TotalCapacity = 131072; HeadroomPercentage = 75 }
+        new Caches.Cache<TTypeCacheKey, bool>(options, "typeSubsumptionCache")
+    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.
 //
@@ -137,13 +187,7 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
 
     if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
         let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce)
-
-        match amap.TypeSubsumptionCache.TryGetValue(key) with
-        | true, subsumes -> subsumes
-        | false, _ ->
-            let subsumes = checkSubsumes ty1 ty2
-            amap.TypeSubsumptionCache.TryAdd(key, subsumes) |> ignore
-            subsumes
+        (getTypeSubsumptionCache g).GetOrAdd(key, fun key -> checkSubsumes key.ty1 key.ty2)
     else
         checkSubsumes ty1 ty2
 

src/Compiler/Checking/TypeRelations.fsi

@@ -9,6 +9,24 @@ open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.Text
 open FSharp.Compiler.TypedTree
 
+[<Struct; NoComparison>]
+type CanCoerce =
+    | CanCoerce
+    | NoCoerce
+
+[<Struct; NoComparison; CustomEquality>]
+type TTypeCacheKey =
+    interface System.IEquatable<TTypeCacheKey>
+    private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
+
+    static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
+
+    val ty1: TType
+    val ty2: TType
+    val canCoerce: CanCoerce
+
+    override GetHashCode: unit -> int
+
 /// Implements a :> b without coercion based on finalized (no type variable) types
 val TypeDefinitelySubsumesTypeNoCoercion:
     ndeep: int -> g: TcGlobals -> amap: ImportMap -> m: range -> ty1: TType -> ty2: TType -> bool

src/Compiler/Checking/import.fs

@@ -50,51 +50,6 @@ type AssemblyLoader =
     abstract RecordGeneratedTypeRoot : ProviderGeneratedType -> unit
 #endif
 
-[<Struct; NoComparison>]
-type CanCoerce =
-    | CanCoerce
-    | NoCoerce
-
-[<Struct; NoComparison; CustomEquality; DebuggerDisplay("{ToString()}")>]
-type TTypeCacheKey =
-
-    val ty1: TType
-    val ty2: TType
-    val canCoerce: CanCoerce
-
-    private new (ty1, ty2, canCoerce) =
-        { ty1 = ty1; ty2 = ty2; canCoerce = canCoerce }
-
-    static member FromStrippedTypes (ty1, ty2, canCoerce) =
-        TTypeCacheKey(ty1, ty2, canCoerce)
-
-    interface System.IEquatable<TTypeCacheKey> with
-        member this.Equals other =
-            if this.canCoerce <> other.canCoerce then
-                false
-            elif this.ty1 === other.ty1 && this.ty2 === other.ty2 then
-                true
-            else
-                HashStamps.stampEquals this.ty1 other.ty1
-                && HashStamps.stampEquals this.ty2 other.ty2
-
-    override this.Equals(other:objnull) =
-        match other with
-        | :? TTypeCacheKey as p -> (this :> System.IEquatable<TTypeCacheKey>).Equals p
-        | _ -> false
-
-    override this.GetHashCode () : int =
-        HashStamps.hashTType this.ty1
-        |> pipeToHash (HashStamps.hashTType this.ty2)
-        |> pipeToHash (hash this.canCoerce)
-
-    override this.ToString () = $"{this.ty1.DebugText}-{this.ty2.DebugText}"
-
-let typeSubsumptionCache =
-    // Leave most of the capacity in reserve for bursts.
-    let options = { CacheOptions.getDefault() with TotalCapacity = 131072; HeadroomPercentage = 75 }
-    lazy new Cache<TTypeCacheKey, bool>(options, "typeSubsumptionCache")
-
 //-------------------------------------------------------------------------
 // Import an IL types as F# types.
 //-------------------------------------------------------------------------
@@ -117,8 +72,6 @@ type ImportMap(g: TcGlobals, assemblyLoader: AssemblyLoader) =
 
     member _.ILTypeRefToTyconRefCache = typeRefToTyconRefCache
 
-    member val TypeSubsumptionCache: Cache<TTypeCacheKey, bool> = typeSubsumptionCache.Value
-
 let CanImportILScopeRef (env: ImportMap) m scoref =
 
     let isResolved assemblyRef =

src/Compiler/Checking/import.fsi

@@ -36,24 +36,6 @@ type AssemblyLoader =
     abstract RecordGeneratedTypeRoot: ProviderGeneratedType -> unit
 #endif
 
-[<Struct; NoComparison>]
-type CanCoerce =
-    | CanCoerce
-    | NoCoerce
-
-[<Struct; NoComparison; CustomEquality>]
-type TTypeCacheKey =
-    interface System.IEquatable<TTypeCacheKey>
-    private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
-
-    static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey
-
-    val ty1: TType
-    val ty2: TType
-    val canCoerce: CanCoerce
-
-    override GetHashCode: unit -> int
-
 /// Represents a context used for converting AbstractIL .NET and provided types to F# internal compiler data structures.
 /// Also cache the conversion of AbstractIL ILTypeRef nodes, based on hashes of these.
 ///
@@ -70,9 +52,6 @@ type ImportMap =
     /// The TcGlobals for the import context
     member g: TcGlobals
 
-    /// Type subsumption cache
-    member TypeSubsumptionCache: Cache<TTypeCacheKey, bool>
-
 module Nullness =
 
     [<Struct; NoEquality; NoComparison>]

src/Compiler/Optimize/Optimizer.fs

@@ -9,6 +9,7 @@ open Internal.Utilities.Collections
 open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
 open FSharp.Compiler
+open FSharp.Compiler.Caches
 open FSharp.Compiler.AbstractIL.Diagnostics
 open FSharp.Compiler.AbstractIL.IL
 open FSharp.Compiler.AttributeChecking
@@ -36,6 +37,10 @@ open System.Collections.ObjectModel
 
 let OptimizerStackGuardDepth = GetEnvInteger "FSHARP_Optimizer" 50
 
+let getFreeLocalsCache =
+    let options = CacheOptions.getReferenceIdentity() |> CacheOptions.withNoEviction
+    WeakMap.getOrCreate <| fun _ -> new Cache<_, _>(options,  "freeLocalsCache")
+
 let i_ldlen = [ I_ldlen; (AI_conv DT_I4) ] 
 
 /// size of a function call 
@@ -2898,10 +2903,11 @@ and OptimizeLinearExpr cenv env expr contf =
 
       let (bindR, bindingInfo), env = OptimizeBinding cenv false env bind 
 
-      OptimizeLinearExpr cenv env body (contf << (fun (bodyR, bodyInfo) ->  
+      OptimizeLinearExpr cenv env body (contf << (fun (bodyR, bodyInfo) -> 
         // PERF: This call to ValueIsUsedOrHasEffect/freeInExpr amounts to 9% of all optimization time.
         // Is it quadratic or quasi-quadratic?
-        if ValueIsUsedOrHasEffect cenv (fun () -> (freeInExpr (CollectLocalsWithStackGuard()) bodyR).FreeLocals) (bindR, bindingInfo) then
+        let collect expr = (freeInExpr (CollectLocalsWithStackGuard()) expr).FreeLocals
+        if ValueIsUsedOrHasEffect cenv (fun () -> (getFreeLocalsCache cenv).GetOrAdd(bodyR, collect)) (bindR, bindingInfo) then
             // Eliminate let bindings on the way back up
             let exprR, adjust = TryEliminateLet cenv env bindR bodyR m 
             exprR, 

src/Compiler/Service/FSharpCheckerResults.fs

@@ -538,7 +538,7 @@ type internal TypeCheckInfo
                         // check that type of value is the same or subtype of tcref
                         // yes - allow access to protected members
                         // no - strip ability to access protected members
-                        if TypeRelations.TypeFeasiblySubsumesType 0 g amap m thisTy Import.CanCoerce ty then
+                        if TypeRelations.TypeFeasiblySubsumesType 0 g amap m thisTy TypeRelations.CanCoerce ty then
                             ad
                         else
                             AccessibleFrom(paths, None)