Caches: remove EntityPool, improve metrics, add eviction stress test (#18786)

Author: majocha

src/Compiler/Checking/TypeRelations.fs

@@ -101,20 +101,6 @@ let TypesFeasiblyEquiv ndeep g amap m ty1 ty2 =
 let TypesFeasiblyEquivStripMeasures g amap m ty1 ty2 =
     TypesFeasiblyEquivalent true 0 g amap m ty1 ty2
 
-let inline TryGetCachedTypeSubsumption (g: TcGlobals) (amap: ImportMap) key =
-    if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
-        match amap.TypeSubsumptionCache.TryGetValue(key) with
-        | true, subsumes ->
-            ValueSome subsumes
-        | false, _ ->
-            ValueNone
-    else
-        ValueNone
-
-let inline UpdateCachedTypeSubsumption (g: TcGlobals) (amap: ImportMap) key subsumes : unit =
-    if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then
-        amap.TypeSubsumptionCache.TryAdd(key, subsumes) |> ignore
-
 /// The feasible coercion relation. Part of the language spec.
 let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1: TType) (canCoerce: CanCoerce) (ty2: TType) =
 
@@ -124,41 +110,42 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1:
     let ty1 = stripTyEqns g ty1
     let ty2 = stripTyEqns g ty2
 
-    // Check if language feature supported
-    let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce)
-
-    match TryGetCachedTypeSubsumption g amap key with
-    | ValueSome subsumes ->
-        subsumes
-    | ValueNone ->
-        let subsumes =
-            match ty1, ty2 with
-            | TType_measure _, TType_measure _
-            | TType_var _, _ | _, TType_var _ ->
-                true
-
-            | TType_app (tc1, l1, _), TType_app (tc2, l2, _) when tyconRefEq g tc1 tc2 ->
-                List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
-
-            | TType_tuple _, TType_tuple _
-            | TType_anon _, TType_anon _
-            | TType_fun _, TType_fun _ ->
-                TypesFeasiblyEquiv ndeep g amap m ty1 ty2
-
-            | _ ->
-                // F# reference types are subtypes of type 'obj'
-                    if isObjTyAnyNullness g ty1 && (canCoerce = CanCoerce || isRefTy g ty2) then
-                        true
-                    elif isAppTy g ty2 && (canCoerce = CanCoerce || isRefTy g ty2) && TypeFeasiblySubsumesTypeWithSupertypeCheck g amap m ndeep ty1 ty2 then
-                        true
-                    else
-                        let interfaces = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty2
-                        // See if any interface in type hierarchy of ty2 is a supertype of ty1
-                        List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces
-
-        UpdateCachedTypeSubsumption g amap key subsumes
-
-        subsumes
+    let checkSubsumes ty1 ty2 =
+        match ty1, ty2 with
+        | TType_measure _, TType_measure _
+        | TType_var _, _ | _, TType_var _ ->
+            true
+
+        | TType_app (tc1, l1, _), TType_app (tc2, l2, _) when tyconRefEq g tc1 tc2 ->
+            List.lengthsEqAndForall2 (TypesFeasiblyEquiv ndeep g amap m) l1 l2
+
+        | TType_tuple _, TType_tuple _
+        | TType_anon _, TType_anon _
+        | TType_fun _, TType_fun _ ->
+            TypesFeasiblyEquiv ndeep g amap m ty1 ty2
+
+        | _ ->
+            // F# reference types are subtypes of type 'obj'
+                if isObjTyAnyNullness g ty1 && (canCoerce = CanCoerce || isRefTy g ty2) then
+                    true
+                elif isAppTy g ty2 && (canCoerce = CanCoerce || isRefTy g ty2) && TypeFeasiblySubsumesTypeWithSupertypeCheck g amap m ndeep ty1 ty2 then
+                    true
+                else
+                    let interfaces = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty2
+                    // See if any interface in type hierarchy of ty2 is a supertype of ty1
+                    List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces
+
+    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
+    else
+        checkSubsumes ty1 ty2
 
 and TypeFeasiblySubsumesTypeWithSupertypeCheck g amap m ndeep ty1 ty2 =
     match GetSuperTypeOfType g amap m ty2 with

src/Compiler/Utilities/Caches.fs

@@ -7,6 +7,7 @@ open System.Collections.Concurrent
 open System.Threading
 open System.Diagnostics
 open System.Diagnostics.Metrics
+open System.Collections.Immutable
 
 [<Struct; RequireQualifiedAccess; NoComparison; NoEquality>]
 type CacheOptions =
@@ -47,112 +48,80 @@ type CachedEntity<'Key, 'Value> =
         entity.node <- LinkedListNode(entity)
         entity
 
-    member this.ReUse(key, value) =
-        this.key <- key
-        this.value <- value
-        this
-
     override this.ToString() = $"{this.Key}"
 
 // Currently the Cache itself exposes Metrics.Counters that count raw cache events: hits, misses, evictions etc.
 // This class observes those counters and keeps a snapshot of readings. For now this is used only to print cache stats in debug mode.
 // TODO: We could add some System.Diagnostics.Metrics.Gauge instruments to this class, to get computed stats also exposed as metrics.
-type CacheMetrics(cacheId) =
+type CacheMetrics(cacheId: string) =
     static let meter = new Meter("FSharp.Compiler.Cache")
-
     static let observedCaches = ConcurrentDictionary<string, CacheMetrics>()
 
-    let readings = ConcurrentDictionary<string, int64 ref>()
+    let created = meter.CreateCounter<int64>("created", "count", cacheId)
+    let hits = meter.CreateCounter<int64>("hits", "count", cacheId)
+    let misses = meter.CreateCounter<int64>("misses", "count", cacheId)
+    let evictions = meter.CreateCounter<int64>("evictions", "count", cacheId)
+    let evictionFails = meter.CreateCounter<int64>("eviction-fails", "count", cacheId)
+    let allCouinters = [ created; hits; misses; evictions; evictionFails ]
 
-    let listener = new MeterListener()
+    let totals =
+        let builder = ImmutableDictionary.CreateBuilder<Instrument, int64 ref>()
 
-    do
-        listener.InstrumentPublished <-
-            fun i l ->
-                if i.Meter = meter && i.Description = cacheId then
-                    l.EnableMeasurementEvents(i)
+        for counter in allCouinters do
+            builder.Add(counter, ref 0L)
 
-        listener.SetMeasurementEventCallback<int64>(fun k v _ _ -> Interlocked.Add(readings.GetOrAdd(k.Name, ref 0L), v) |> ignore)
-        listener.Start()
+        builder.ToImmutable()
 
-    member this.Dispose() = listener.Dispose()
+    let incr key v =
+        Interlocked.Add(totals[key], v) |> ignore
 
-    member val CacheId = cacheId
+    let total key = totals[key].Value
 
-    static member val Meter = meter
+    let mutable ratio = Double.NaN
 
-    member val RecentStats = "-" with get, set
-
-    member this.TryUpdateStats(clearCounts) =
-        let ratio =
-            try
-                float readings["hits"].Value
-                / float (readings["hits"].Value + readings["misses"].Value)
-                * 100.0
-            with _ ->
-                Double.NaN
-
-        let stats =
-            [
-                for name in readings.Keys do
-                    let v = readings[name].Value
-
-                    if v > 0 then
-                        $"{name}: {v}"
-            ]
-            |> String.concat ", "
-            |> sprintf "%s | hit ratio: %s %s" this.CacheId (if Double.IsNaN(ratio) then "-" else $"%.1f{ratio}%%")
-
-        if clearCounts then
-            for r in readings.Values do
-                Interlocked.Exchange(r, 0L) |> ignore
-
-        if stats <> this.RecentStats then
-            this.RecentStats <- stats
-            true
-        else
-            false
+    let updateRatio () =
+        ratio <- float (total hits) / float (total hits + total misses)
 
-    // TODO: Should return a Map, not a string
-    static member GetStats(cacheId) =
-        observedCaches[cacheId].TryUpdateStats(false) |> ignore
-        observedCaches[cacheId].RecentStats
+    let listener = new MeterListener()
 
-    static member GetStatsUpdateForAllCaches(clearCounts) =
-        [
-            for i in observedCaches.Values do
-                if i.TryUpdateStats(clearCounts) then
-                    i.RecentStats
-        ]
-        |> String.concat "\n"
+    let startListening () =
+        for i in allCouinters do
+            listener.EnableMeasurementEvents i
 
-    static member AddInstrumentation(cacheId) =
-        if observedCaches.ContainsKey cacheId then
-            invalidArg "cacheId" $"cache with name {cacheId} already exists"
+        listener.SetMeasurementEventCallback(fun instrument v _ _ ->
+            incr instrument v
 
-        observedCaches[cacheId] <- new CacheMetrics(cacheId)
+            if instrument = hits || instrument = misses then
+                updateRatio ())
 
-    static member RemoveInstrumentation(cacheId) =
-        observedCaches[cacheId].Dispose()
-        observedCaches.TryRemove(cacheId) |> ignore
+        listener.Start()
 
-// Creates and after reclaiming holds entities for reuse.
-// More than totalCapacity can be created, but it will hold for reuse at most totalCapacity.
-type EntityPool<'Key, 'Value>(totalCapacity, cacheId) =
-    let pool = ConcurrentBag<CachedEntity<'Key, 'Value>>()
+    member val Created = created
+    member val Hits = hits
+    member val Misses = misses
+    member val Evictions = evictions
+    member val EvictionFails = evictionFails
 
-    let created = CacheMetrics.Meter.CreateCounter<int64>("created", "count", cacheId)
+    member this.ObserveMetrics() =
+        observedCaches[cacheId] <- this
+        startListening ()
 
-    member _.Acquire(key, value) =
-        match pool.TryTake() with
-        | true, entity -> entity.ReUse(key, value)
-        | _ ->
-            created.Add 1L
-            CachedEntity.Create(key, value)
+    member this.Dispose() =
+        observedCaches.TryRemove cacheId |> ignore
+        listener.Dispose()
+
+    member _.GetInstanceTotals() =
+        [ for k in totals.Keys -> k.Name, total k ] |> Map.ofList
 
-    member _.Reclaim(entity: CachedEntity<'Key, 'Value>) =
-        if pool.Count < totalCapacity then
-            pool.Add(entity)
+    member _.GetInstanceStats() = [ "hit-ratio", ratio ] |> Map.ofList
+
+    static member val Meter = meter
+
+    static member GetTotals(cacheId) =
+        observedCaches[cacheId].GetInstanceTotals()
+
+    static member GetStats(cacheId) =
+        observedCaches[cacheId].GetInstanceStats()
 
 module Cache =
     // During testing a lot of compilations are started in app domains and subprocesses.
@@ -176,25 +145,13 @@ type EvictionQueueMessage<'Key, 'Value> =
 
 [<Sealed; NoComparison; NoEquality>]
 [<DebuggerDisplay("{GetStats()}")>]
-type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalCapacity, headroom, ?name, ?observeMetrics) =
-
-    let instanceId = defaultArg name (Guid.NewGuid().ToString())
+type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalCapacity, headroom, name, listen) =
 
-    let observeMetrics = defaultArg observeMetrics false
+    let metrics = new CacheMetrics(name)
 
     do
-        if observeMetrics then
-            CacheMetrics.AddInstrumentation instanceId
-
-    let meter = CacheMetrics.Meter
-    let hits = meter.CreateCounter<int64>("hits", "count", instanceId)
-    let misses = meter.CreateCounter<int64>("misses", "count", instanceId)
-    let evictions = meter.CreateCounter<int64>("evictions", "count", instanceId)
-
-    let evictionFails =
-        meter.CreateCounter<int64>("eviction-fails", "count", instanceId)
-
-    let pool = EntityPool<'Key, 'Value>(totalCapacity, instanceId)
+        if listen then
+            metrics.ObserveMetrics()
 
     let store =
         ConcurrentDictionary<'Key, CachedEntity<'Key, 'Value>>(Environment.ProcessorCount, totalCapacity)
@@ -205,6 +162,7 @@ type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalC
     let capacity = totalCapacity - headroom
 
     let evicted = Event<_>()
+    let evictionFailed = Event<_>()
 
     let cts = new CancellationTokenSource()
 
@@ -222,12 +180,14 @@ type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalC
                                 let first = nonNull evictionQueue.First
 
                                 match store.TryRemove(first.Value.Key) with
-                                | true, removed ->
+                                | true, _ ->
                                     evictionQueue.Remove(first)
-                                    pool.Reclaim(removed)
-                                    evictions.Add 1L
+                                    metrics.Evictions.Add 1L
                                     evicted.Trigger()
-                                | _ -> evictionFails.Add 1L
+                                | _ ->
+                                    // This should not be possible to happen, but if it does, we want to know.
+                                    metrics.EvictionFails.Add 1L
+                                    evictionFailed.Trigger()
 
                         // Store updates are not synchronized. It is possible the entity is no longer in the queue.
                         | EvictionQueueMessage.Update entity when isNull entity.Node.List -> ()
@@ -245,30 +205,27 @@ type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalC
         )
 
     member val Evicted = evicted.Publish
-
-    member val Name = instanceId
+    member val EvictionFailed = evictionFailed.Publish
 
     member _.TryGetValue(key: 'Key, value: outref<'Value>) =
         match store.TryGetValue(key) with
         | true, entity ->
-            hits.Add 1L
+            metrics.Hits.Add 1L
             evictionProcessor.Post(EvictionQueueMessage.Update entity)
             value <- entity.Value
             true
         | _ ->
-            misses.Add 1L
+            metrics.Misses.Add 1L
             value <- Unchecked.defaultof<'Value>
             false
 
     member _.TryAdd(key: 'Key, value: 'Value) =
-        let entity = pool.Acquire(key, value)
+        let entity = CachedEntity.Create(key, value)
 
         let added = store.TryAdd(key, entity)
 
         if added then
             evictionProcessor.Post(EvictionQueueMessage.Add entity)
-        else
-            pool.Reclaim(entity)
 
         added
 
@@ -278,14 +235,10 @@ type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalC
             cts.Dispose()
             evictionProcessor.Dispose()
             store.Clear()
-
-            if observeMetrics then
-                CacheMetrics.RemoveInstrumentation instanceId
+            metrics.Dispose()
 
     member this.Dispose() = (this :> IDisposable).Dispose()
 
-    member this.GetStats() = CacheMetrics.GetStats(this.Name)
-
     static member Create<'Key, 'Value>(options: CacheOptions, ?name, ?observeMetrics) =
         if options.TotalCapacity < 0 then
             invalidArg "Capacity" "Capacity must be positive"
@@ -298,7 +251,9 @@ type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalC
         let headroom =
             int (float options.TotalCapacity * float options.HeadroomPercentage / 100.0)
 
-        let cache =
-            new Cache<_, _>(totalCapacity, headroom, ?name = name, ?observeMetrics = observeMetrics)
+        let name = defaultArg name (Guid.NewGuid().ToString())
+        let observeMetrics = defaultArg observeMetrics false
+
+        let cache = new Cache<_, _>(totalCapacity, headroom, name, observeMetrics)
 
         cache