print stats with --times (#18930)

majocha · web-flow · commit c0c7bb5c2adf · 2025-09-23T11:53:15.000+02:00
diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs
@@ -35,8 +35,8 @@ 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 = 65536; HeadroomPercentage = 75 }
+            | 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     
 
diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs
@@ -569,6 +569,7 @@ let main1
             exiter.Exit 1
 
     if tcConfig.showTimes then
+        Caches.CacheMetrics.CaptureStatsAndWriteToConsole() |> disposables.Register
         Activity.Profiling.addConsoleListener () |> disposables.Register
 
     tcConfig.writeTimesToFile
diff --git a/src/Compiler/Utilities/Caches.fs b/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.IO
 
 module CacheMetrics =
     let Meter = new Meter("FSharp.Compiler.Cache")
@@ -22,57 +23,153 @@ module CacheMetrics =
     let creations = Meter.CreateCounter<int64>("creations", "count")
     let disposals = Meter.CreateCounter<int64>("disposals", "count")
 
-    let mkTag name = KeyValuePair<_, obj>("name", name)
+    let mutable private nextCacheId = 0
 
-    let Add (tag: KeyValuePair<_, _>) = adds.Add(1L, tag)
-    let Update (tag: KeyValuePair<_, _>) = updates.Add(1L, tag)
-    let Hit (tag: KeyValuePair<_, _>) = hits.Add(1L, tag)
-    let Miss (tag: KeyValuePair<_, _>) = misses.Add(1L, tag)
-    let Eviction (tag: KeyValuePair<_, _>) = evictions.Add(1L, tag)
-    let EvictionFail (tag: KeyValuePair<_, _>) = evictionFails.Add(1L, tag)
-    let Created (tag: KeyValuePair<_, _>) = creations.Add(1L, tag)
-    let Disposed (tag: KeyValuePair<_, _>) = disposals.Add(1L, tag)
+    let mkTags (name: string) =
+        let cacheId = Interlocked.Increment &nextCacheId
+        // Avoid TagList(ReadOnlySpan<...>) to support net472 runtime
+        let mutable tags = TagList()
+        tags.Add("name", box name)
+        tags.Add("cacheId", box cacheId)
+        tags
 
-// Currently the Cache emits telemetry for raw cache events: hits, misses, evictions etc.
-// This class observes those counters and keeps a snapshot of readings. It is used in tests and can be used to print cache stats in debug mode.
-type CacheMetricsListener(tag) =
-    let totals = Map [ for counter in CacheMetrics.allCounters -> counter.Name, ref 0L ]
+    let Add (tags: inref<TagList>) = adds.Add(1L, &tags)
+    let Update (tags: inref<TagList>) = updates.Add(1L, &tags)
+    let Hit (tags: inref<TagList>) = hits.Add(1L, &tags)
+    let Miss (tags: inref<TagList>) = misses.Add(1L, &tags)
+    let Eviction (tags: inref<TagList>) = evictions.Add(1L, &tags)
+    let EvictionFail (tags: inref<TagList>) = evictionFails.Add(1L, &tags)
+    let Created (tags: inref<TagList>) = creations.Add(1L, &tags)
+    let Disposed (tags: inref<TagList>) = disposals.Add(1L, &tags)
 
-    let incr key v =
-        Interlocked.Add(totals[key], v) |> ignore
+    type Stats() =
+        let totals = Map [ for counter in allCounters -> counter.Name, ref 0L ]
+        let total key = totals[key].Value
 
-    let total key = totals[key].Value
+        let mutable ratio = Double.NaN
 
-    let mutable ratio = Double.NaN
+        let updateRatio () =
+            ratio <- float (total hits.Name) / float (total hits.Name + total misses.Name)
 
-    let updateRatio () =
-        ratio <-
-            float (total CacheMetrics.hits.Name)
-            / float (total CacheMetrics.hits.Name + total CacheMetrics.misses.Name)
+        member _.Incr key v =
+            assert (totals.ContainsKey key)
+            Interlocked.Add(totals[key], v) |> ignore
 
-    let listener = new MeterListener()
+            if key = hits.Name || key = misses.Name then
+                updateRatio ()
 
-    do
+        member _.GetTotals() =
+            [ for k in totals.Keys -> k, total k ] |> Map.ofList
+
+        member _.Ratio = ratio
+
+        override _.ToString() =
+            let parts =
+                [
+                    for kv in totals do
+                        yield $"{kv.Key}={kv.Value.Value}"
+                    if not (Double.IsNaN ratio) then
+                        yield $"hit-ratio={ratio:P2}"
+                ]
+
+            String.Join(", ", parts)
+
+    let statsByName = ConcurrentDictionary<string, Stats>()
+
+    let getStatsByName name =
+        statsByName.GetOrAdd(name, fun _ -> Stats())
+
+    let ListenToAll () =
+        let listener = new MeterListener()
 
-        for instrument in CacheMetrics.allCounters do
+        for instrument in allCounters do
             listener.EnableMeasurementEvents instrument
 
         listener.SetMeasurementEventCallback(fun instrument v tags _ ->
-            if tags[0] = tag then
-                incr instrument.Name v
-
-                if instrument = CacheMetrics.hits || instrument = CacheMetrics.misses then
-                    updateRatio ())
+            match tags[0].Value with
+            | :? string as name ->
+                let stats = getStatsByName name
+                stats.Incr instrument.Name v
+            | _ -> assert false)
 
         listener.Start()
+        listener :> IDisposable
+
+    let StatsToString () =
+        use sw = new StringWriter()
+
+        let nameColumnWidth =
+            [ yield! statsByName.Keys; "Cache name" ] |> Seq.map String.length |> Seq.max
+
+        let columns = allCounters |> List.map _.Name
+        let columnWidths = columns |> List.map String.length |> List.map (max 8)
+
+        let header =
+            "| "
+            + String.concat
+                " | "
+                [
+                    "Cache name".PadRight nameColumnWidth
+                    "hit-ratio"
+                    for w, c in (columnWidths, columns) ||> List.zip do
+                        $"{c.PadLeft w}"
+                ]
+            + " |"
+
+        sw.WriteLine(String('-', header.Length))
+        sw.WriteLine(header)
+        sw.WriteLine(header |> String.map (fun c -> if c = '|' then '|' else '-'))
+
+        for kv in statsByName do
+            let name = kv.Key
+            let stats = kv.Value
+            let totals = stats.GetTotals()
+            sw.Write $"| {name.PadLeft nameColumnWidth} | {stats.Ratio, 9:P2} |"
+
+            for w, c in (columnWidths, columns) ||> List.zip do
+                sw.Write $" {totals[c].ToString().PadLeft(w)} |"
+
+            sw.WriteLine()
+
+        sw.WriteLine(String('-', header.Length))
+        string sw
+
+    let CaptureStatsAndWriteToConsole () =
+        let listener = ListenToAll()
+
+        { new IDisposable with
+            member _.Dispose() =
+                listener.Dispose()
+                Console.WriteLine(StatsToString())
+        }
 
-    interface IDisposable with
-        member _.Dispose() = listener.Dispose()
+    // Currently the Cache emits telemetry for raw cache events: hits, misses, evictions etc.
+    // This type observes those counters and keeps a snapshot of readings. It is used in tests and can be used to print cache stats in debug mode.
+    type CacheMetricsListener(cacheTags: TagList) =
+
+        let stats = Stats()
+        let listener = new MeterListener()
+
+        do
+            for instrument in allCounters do
+                listener.EnableMeasurementEvents instrument
+
+            listener.SetMeasurementEventCallback(fun instrument v tags _ ->
+                let tagsMatch = tags[0] = cacheTags[0] && tags[1] = cacheTags[1]
 
-    member _.GetTotals() =
-        [ for k in totals.Keys -> k, total k ] |> Map.ofList
+                if tagsMatch then
+                    stats.Incr instrument.Name v)
 
-    member _.GetStats() = [ "hit-ratio", ratio ] |> Map.ofList
+            listener.Start()
+
+        interface IDisposable with
+            member _.Dispose() = listener.Dispose()
+
+        member _.GetTotals() = stats.GetTotals()
+
+        member _.Ratio = stats.Ratio
+
+        override _.ToString() = stats.ToString()
 
 [<RequireQualifiedAccess>]
 type EvictionMode =
@@ -97,22 +194,17 @@ type CacheOptions<'Key> =
     }
 
 module CacheOptions =
-    let getDefault () =
-        {
-            CacheOptions.TotalCapacity = 1024
-            CacheOptions.HeadroomPercentage = 50
-            CacheOptions.EvictionMode = EvictionMode.MailboxProcessor
-            CacheOptions.Comparer = HashIdentity.Structural
-        }
 
-    let getReferenceIdentity () =
+    let getDefault comparer =
         {
             CacheOptions.TotalCapacity = 1024
             CacheOptions.HeadroomPercentage = 50
             CacheOptions.EvictionMode = EvictionMode.MailboxProcessor
-            CacheOptions.Comparer = HashIdentity.Reference
+            CacheOptions.Comparer = comparer
         }
 
+    let getReferenceIdentity () = getDefault HashIdentity.Reference
+
     let withNoEviction options =
         { options with
             CacheOptions.EvictionMode = EvictionMode.NoEviction
@@ -151,7 +243,7 @@ type EvictionQueueMessage<'Entity, 'Target> =
     | Update of 'Entity
 
 [<Sealed; NoComparison; NoEquality>]
-[<DebuggerDisplay("{GetStats()}")>]
+[<DebuggerDisplay("{DebugDisplay()}")>]
 type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Key>, ?name) =
 
     do
@@ -178,7 +270,7 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
     let evicted = Event<_>()
     let evictionFailed = Event<_>()
 
-    let tag = CacheMetrics.mkTag name
+    let tags = CacheMetrics.mkTags name
 
     // Track disposal state (0 = not disposed, 1 = disposed)
     let mutable disposed = 0
@@ -211,10 +303,10 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
 
                 match store.TryRemove(first.Value.Key) with
                 | true, _ ->
-                    CacheMetrics.Eviction tag
+                    CacheMetrics.Eviction &tags
                     evicted.Trigger()
                 | _ ->
-                    CacheMetrics.EvictionFail tag
+                    CacheMetrics.EvictionFail &tags
                     evictionFailed.Trigger()
                     deadKeysCount <- deadKeysCount + 1
 
@@ -262,20 +354,24 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
 
             post, dispose
 
-    do CacheMetrics.Created tag
+#if DEBUG
+    let debugListener = new CacheMetrics.CacheMetricsListener(tags)
+#endif
+
+    do CacheMetrics.Created &tags
 
     member val Evicted = evicted.Publish
     member val EvictionFailed = evictionFailed.Publish
 
     member _.TryGetValue(key: 'Key, value: outref<'Value>) =
         match store.TryGetValue(key) with
         | true, entity ->
-            CacheMetrics.Hit tag
+            CacheMetrics.Hit &tags
             post (EvictionQueueMessage.Update entity)
             value <- entity.Value
             true
         | _ ->
-            CacheMetrics.Miss tag
+            CacheMetrics.Miss &tags
             value <- Unchecked.defaultof<'Value>
             false
 
@@ -285,7 +381,7 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
         let added = store.TryAdd(key, entity)
 
         if added then
-            CacheMetrics.Add tag
+            CacheMetrics.Add &tags
             post (EvictionQueueMessage.Add(entity, store))
 
         added
@@ -302,11 +398,11 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
 
         if wasMiss then
             post (EvictionQueueMessage.Add(result, store))
-            CacheMetrics.Add tag
-            CacheMetrics.Miss tag
+            CacheMetrics.Add &tags
+            CacheMetrics.Miss &tags
         else
             post (EvictionQueueMessage.Update result)
-            CacheMetrics.Hit tag
+            CacheMetrics.Hit &tags
 
         result.Value
 
@@ -321,18 +417,19 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
 
         // Returned value tells us if the entity was added or updated.
         if Object.ReferenceEquals(addValue, result) then
-            CacheMetrics.Add tag
+            CacheMetrics.Add &tags
             post (EvictionQueueMessage.Add(addValue, store))
         else
-            CacheMetrics.Update tag
+            CacheMetrics.Update &tags
             post (EvictionQueueMessage.Update result)
 
-    member _.CreateMetricsListener() = new CacheMetricsListener(tag)
+    member _.CreateMetricsListener() =
+        new CacheMetrics.CacheMetricsListener(tags)
 
     member _.Dispose() =
         if Interlocked.Exchange(&disposed, 1) = 0 then
             disposeEvictionProcessor ()
-            CacheMetrics.Disposed tag
+            CacheMetrics.Disposed &tags
 
     interface IDisposable with
         member this.Dispose() =
@@ -341,3 +438,7 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke
 
     // Finalizer to ensure eviction loop is cancelled if Dispose wasn't called.
     override this.Finalize() = this.Dispose()
+
+#if DEBUG
+    member _.DebugDisplay() = debugListener.ToString()
+#endif
diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi
@@ -8,13 +8,16 @@ module internal CacheMetrics =
     /// Global telemetry Meter for all caches. Exposed for testing purposes.
     /// Set FSHARP_OTEL_EXPORT environment variable to enable OpenTelemetry export to external collectors in tests.
     val Meter: Meter
+    val ListenToAll: unit -> IDisposable
+    val StatsToString: unit -> string
+    val CaptureStatsAndWriteToConsole: unit -> IDisposable
 
-[<Class>]
-/// A local listener that can be created for a specific Cache instance to get its metrics. For testing purposes only.
-type internal CacheMetricsListener =
-    member GetStats: unit -> Map<string, float>
-    member GetTotals: unit -> Map<string, int64>
-    interface IDisposable
+    /// A local listener that can be created for a specific Cache instance to get its metrics. For testing purposes only.
+    [<Class>]
+    type internal CacheMetricsListener =
+        member Ratio: float
+        member GetTotals: unit -> Map<string, int64>
+        interface IDisposable
 
 [<RequireQualifiedAccess; NoComparison>]
 type internal EvictionMode =
@@ -43,7 +46,7 @@ type internal CacheOptions<'Key> =
 
 module internal CacheOptions =
     /// Default options, using structural equality for keys and queued eviction.
-    val getDefault: unit -> CacheOptions<'Key> when 'Key: equality
+    val getDefault: IEqualityComparer<'Key> -> CacheOptions<'Key>
     /// Default options, using reference equality for keys and queued eviction.
     val getReferenceIdentity: unit -> CacheOptions<'Key> when 'Key: not struct
     /// Set eviction mode to NoEviction.
@@ -64,4 +67,4 @@ type internal Cache<'Key, 'Value when 'Key: not null> =
     /// For testing only.
     member EvictionFailed: IEvent<unit>
     /// For testing only. Creates a local telemetry listener for this cache instance.
-    member CreateMetricsListener: unit -> CacheMetricsListener
+    member CreateMetricsListener: unit -> CacheMetrics.CacheMetricsListener
diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs
