diff --git a/docs/release-notes/.FSharp.Compiler.Service/9.0.300.md b/docs/release-notes/.FSharp.Compiler.Service/9.0.300.md index 7cb7eae4d6c..c39b44e1d7a 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/9.0.300.md +++ b/docs/release-notes/.FSharp.Compiler.Service/9.0.300.md @@ -40,6 +40,7 @@ * Type parameter constraint `null` in generic code will now automatically imply `not struct` ([Issue #18320](https://github.com/dotnet/fsharp/issues/18320), [PR #18323](https://github.com/dotnet/fsharp/pull/18323)) * Add a switch to determine whether to generate a default implementation body for overridden method when completing. [PR #18341](https://github.com/dotnet/fsharp/pull/18341) * Use a more accurate range for CE Combine methods. [PR #18394](https://github.com/dotnet/fsharp/pull/18394) +* Enable TypeSubsumptionCache for IDE use. [PR #18499](https://github.com/dotnet/fsharp/pull/18499) ### Changed diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 2cb5dd4057a..fddf6027875 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -102,7 +102,7 @@ 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.compilationMode = CompilationMode.OneOff && g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then + if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then match amap.TypeSubsumptionCache.TryGetValue(key) with | true, subsumes -> ValueSome subsumes @@ -112,8 +112,8 @@ let inline TryGetCachedTypeSubsumption (g: TcGlobals) (amap: ImportMap) key = ValueNone let inline UpdateCachedTypeSubsumption (g: TcGlobals) (amap: ImportMap) key subsumes : unit = - if g.compilationMode = CompilationMode.OneOff && g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then - amap.TypeSubsumptionCache[key] <- subsumes + 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) = @@ -125,7 +125,7 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1: let ty2 = stripTyEqns g ty2 // Check if language feature supported - let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce, g) + let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce) match TryGetCachedTypeSubsumption g amap key with | ValueSome subsumes -> diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index c87d6cdad03..f1f44090f19 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -6,22 +6,25 @@ module internal FSharp.Compiler.Import open System.Collections.Concurrent open System.Collections.Generic open System.Collections.Immutable -open FSharp.Compiler.Text.Range +open System.Diagnostics + open Internal.Utilities.Library open Internal.Utilities.Library.Extras open Internal.Utilities.TypeHashing -open Internal.Utilities.TypeHashing.HashTypes + open FSharp.Compiler open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.SyntaxTreeOps open FSharp.Compiler.Text +open FSharp.Compiler.Text.Range open FSharp.Compiler.Xml open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open FSharp.Compiler.TcGlobals +open FSharp.Compiler.Caches #if !NO_TYPEPROVIDERS open FSharp.Compiler.TypeProviders @@ -52,18 +55,18 @@ type CanCoerce = | CanCoerce | NoCoerce -type [] TTypeCacheKey = +[] +type TTypeCacheKey = val ty1: TType val ty2: TType val canCoerce: CanCoerce - val tcGlobals: TcGlobals - private new (ty1, ty2, canCoerce, tcGlobals) = - { ty1 = ty1; ty2 = ty2; canCoerce = canCoerce; tcGlobals = tcGlobals } + private new (ty1, ty2, canCoerce) = + { ty1 = ty1; ty2 = ty2; canCoerce = canCoerce } - static member FromStrippedTypes (ty1, ty2, canCoerce, tcGlobals) = - TTypeCacheKey(ty1, ty2, canCoerce, tcGlobals) + static member FromStrippedTypes (ty1, ty2, canCoerce) = + TTypeCacheKey(ty1, ty2, canCoerce) interface System.IEquatable with member this.Equals other = @@ -72,23 +75,24 @@ type [] TTypeCacheKey = elif this.ty1 === other.ty1 && this.ty2 === other.ty2 then true else - stampEquals this.tcGlobals this.ty1 other.ty1 - && stampEquals this.tcGlobals this.ty2 other.ty2 + 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).Equals p | _ -> false - override this.GetHashCode() : int = - let g = this.tcGlobals - - let ty1Hash = combineHash (hashStamp g this.ty1) (hashTType g this.ty1) - let ty2Hash = combineHash (hashStamp g this.ty2) (hashTType g this.ty2) + override this.GetHashCode () : int = + HashStamps.hashTType this.ty1 + |> pipeToHash (HashStamps.hashTType this.ty2) + |> pipeToHash (hash this.canCoerce) - let combined = combineHash (combineHash ty1Hash ty2Hash) (hash this.canCoerce) + override this.ToString () = $"{this.ty1.DebugText}-{this.ty2.DebugText}" - combined +let typeSubsumptionCache = + // Leave most of the capacity in reserve for bursts. + lazy Cache.Create({ TotalCapacity = 131072; HeadroomPercentage = 75 }, name = "TypeSubsumptionCache") //------------------------------------------------------------------------- // Import an IL types as F# types. @@ -106,15 +110,13 @@ type [] TTypeCacheKey = type ImportMap(g: TcGlobals, assemblyLoader: AssemblyLoader) = let typeRefToTyconRefCache = ConcurrentDictionary() - let typeSubsumptionCache = ConcurrentDictionary(System.Environment.ProcessorCount, 1024) - member _.g = g member _.assemblyLoader = assemblyLoader member _.ILTypeRefToTyconRefCache = typeRefToTyconRefCache - member _.TypeSubsumptionCache = typeSubsumptionCache + member val TypeSubsumptionCache: Cache = typeSubsumptionCache.Value let CanImportILScopeRef (env: ImportMap) m scoref = diff --git a/src/Compiler/Checking/import.fsi b/src/Compiler/Checking/import.fsi index c387558fcba..72611e12bf7 100644 --- a/src/Compiler/Checking/import.fsi +++ b/src/Compiler/Checking/import.fsi @@ -5,13 +5,12 @@ module internal FSharp.Compiler.Import open Internal.Utilities.Library open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.Caches open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text open FSharp.Compiler.Xml open FSharp.Compiler.TypedTree -open System.Collections.Concurrent - #if !NO_TYPEPROVIDERS open FSharp.Compiler.TypeProviders #endif @@ -45,15 +44,14 @@ type CanCoerce = [] type TTypeCacheKey = interface System.IEquatable - private new: ty1: TType * ty2: TType * canCoerce: CanCoerce * tcGlobals: TcGlobals -> TTypeCacheKey + private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey - static member FromStrippedTypes: - ty1: TType * ty2: TType * canCoerce: CanCoerce * tcGlobals: TcGlobals -> TTypeCacheKey + static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey val ty1: TType val ty2: TType val canCoerce: CanCoerce - val tcGlobals: TcGlobals + override GetHashCode: unit -> int /// Represents a context used for converting AbstractIL .NET and provided types to F# internal compiler data structures. @@ -73,7 +71,7 @@ type ImportMap = member g: TcGlobals /// Type subsumption cache - member TypeSubsumptionCache: ConcurrentDictionary + member TypeSubsumptionCache: Cache module Nullness = diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 74e59954e8f..bbddf424684 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -146,6 +146,8 @@ + + diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs new file mode 100644 index 00000000000..04829d4d1f3 --- /dev/null +++ b/src/Compiler/Utilities/Caches.fs @@ -0,0 +1,316 @@ +// LinkedList uses nulls, so we need to disable the nullability warnings for this file. +namespace FSharp.Compiler.Caches + +open System +open System.Collections.Generic +open System.Collections.Concurrent +open System.Threading +open System.Diagnostics +open System.Diagnostics.Metrics + +[] +type CacheOptions = + { + /// Total capacity, determines the size of the underlying store. + TotalCapacity: int + + /// Safety margin size as a percentage of TotalCapacity. + HeadroomPercentage: int + } + + static member Default = + { + TotalCapacity = 128 + HeadroomPercentage = 50 + } + +// It is important that this is not a struct, because LinkedListNode holds a reference to it, +// and it holds the reference to that Node, in a circular way. +[] +[] +type CachedEntity<'Key, 'Value> = + val mutable Key: 'Key + val mutable Value: 'Value + val mutable AccessCount: int64 + val mutable Node: LinkedListNode> voption + + new(key, value) = + { + Key = key + Value = value + AccessCount = 0L + Node = ValueNone + } + + // This is one time initialization, outside of the constructor because of circular reference. + // The contract is that each CachedEntity that the EntityPool produces, has Node assigned. + member this.WithNode() = + this.Node <- ValueSome(LinkedListNode this) + this + + member this.ReUse(key, value) = + this.Key <- key + this.Value <- value + this.AccessCount <- 0L + 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) = + static let meter = new Meter("FSharp.Compiler.Cache") + + static let observedCaches = ConcurrentDictionary() + + let readings = ConcurrentDictionary() + + let listener = new MeterListener() + + do + listener.InstrumentPublished <- + fun i l -> + if i.Meter = meter && i.Description = cacheId then + l.EnableMeasurementEvents(i) + + listener.SetMeasurementEventCallback(fun k v _ _ -> Interlocked.Add(readings.GetOrAdd(k.Name, ref 0L), v) |> ignore) + listener.Start() + + member this.Dispose() = listener.Dispose() + + member val CacheId = cacheId + + static member val Meter = meter + + 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 + + // TODO: Should return a Map, not a string + static member GetStats(cacheId) = + observedCaches[cacheId].TryUpdateStats(false) |> ignore + observedCaches[cacheId].RecentStats + + static member GetStatsUpdateForAllCaches(clearCounts) = + [ + for i in observedCaches.Values do + if i.TryUpdateStats(clearCounts) then + i.RecentStats + ] + |> String.concat "\n" + + static member AddInstrumentation(cacheId) = + if observedCaches.ContainsKey cacheId then + invalidArg "cacheId" $"cache with name {cacheId} already exists" + + observedCaches[cacheId] <- new CacheMetrics(cacheId) + + static member RemoveInstrumentation(cacheId) = + observedCaches[cacheId].Dispose() + observedCaches.TryRemove(cacheId) |> ignore + +// 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>() + let mutable created = 0 + + let overCapacity = + CacheMetrics.Meter.CreateCounter("over-capacity", "count", cacheId) + + member _.Acquire(key, value) = + match pool.TryTake() with + | true, entity -> entity.ReUse(key, value) + | _ -> + if Interlocked.Increment &created > totalCapacity then + overCapacity.Add 1L + + // Associate a LinkedListNode with freshly created entity. + // This is a one time initialization. + CachedEntity(key, value).WithNode() + + member _.Reclaim(entity: CachedEntity<'Key, 'Value>) = + if pool.Count < totalCapacity then + pool.Add(entity) + +module Cache = + // During testing a lot of compilations are started in app domains and subprocesses. + // This is a reliable way to pass the override to all of them. + [] + let private overrideVariable = "FSHARP_CACHE_OVERRIDE" + + /// Use for testing purposes to reduce memory consumption in testhost and its subprocesses. + let OverrideCapacityForTesting () = + Environment.SetEnvironmentVariable(overrideVariable, "true", EnvironmentVariableTarget.Process) + + let applyOverride (capacity: int) = + match Environment.GetEnvironmentVariable(overrideVariable) with + | NonNull _ when capacity > 4096 -> 4096 + | _ -> capacity + +[] +type EvictionQueueMessage<'Key, 'Value> = + | Add of CachedEntity<'Key, 'Value> + | Update of CachedEntity<'Key, 'Value> + +[] +[] +type Cache<'Key, 'Value when 'Key: not null and 'Key: equality> internal (totalCapacity, headroom, ?name, ?observeMetrics) = + + let instanceId = defaultArg name (Guid.NewGuid().ToString()) + + let observeMetrics = defaultArg observeMetrics false + + do + if observeMetrics then + CacheMetrics.AddInstrumentation instanceId + + let meter = CacheMetrics.Meter + let hits = meter.CreateCounter("hits", "count", instanceId) + let misses = meter.CreateCounter("misses", "count", instanceId) + let evictions = meter.CreateCounter("evictions", "count", instanceId) + + let evictionFails = + meter.CreateCounter("eviction-fails", "count", instanceId) + + let pool = EntityPool<'Key, 'Value>(totalCapacity, instanceId) + + let store = + ConcurrentDictionary<'Key, CachedEntity<'Key, 'Value>>(Environment.ProcessorCount, totalCapacity) + + let evictionQueue = LinkedList>() + + // Non-evictable capacity. + let capacity = totalCapacity - headroom + + let evicted = Event<_>() + + let cts = new CancellationTokenSource() + + let evictionProcessor = + MailboxProcessor.Start( + (fun mb -> + let rec processNext () = + async { + match! mb.Receive() with + | EvictionQueueMessage.Add entity -> + + assert entity.Node.IsSome + + evictionQueue.AddLast(entity.Node.Value) + + // Evict one immediately if necessary. + while evictionQueue.Count > capacity do + let first = nonNull evictionQueue.First + + match store.TryRemove(first.Value.Key) with + | true, removed -> + evictionQueue.Remove(first) + pool.Reclaim(removed) + evictions.Add 1L + evicted.Trigger() + | _ -> evictionFails.Add 1L + + | EvictionQueueMessage.Update entity -> + entity.AccessCount <- entity.AccessCount + 1L + + assert entity.Node.IsSome + + let node = entity.Node.Value + assert (node.List = evictionQueue) + // Just move this node to the end of the list. + evictionQueue.Remove(node) + evictionQueue.AddLast(node) + + return! processNext () + } + + processNext ()), + cts.Token + ) + + member val Evicted = evicted.Publish + + member val Name = instanceId + + member _.TryGetValue(key: 'Key, value: outref<'Value>) = + match store.TryGetValue(key) with + | true, cachedEntity -> + hits.Add 1L + evictionProcessor.Post(EvictionQueueMessage.Update cachedEntity) + value <- cachedEntity.Value + true + | _ -> + misses.Add 1L + value <- Unchecked.defaultof<'Value> + false + + member _.TryAdd(key: 'Key, value: 'Value) = + let cachedEntity = pool.Acquire(key, value) + + if store.TryAdd(key, cachedEntity) then + evictionProcessor.Post(EvictionQueueMessage.Add cachedEntity) + true + else + pool.Reclaim(cachedEntity) + false + + interface IDisposable with + member this.Dispose() = + cts.Cancel() + cts.Dispose() + evictionProcessor.Dispose() + store.Clear() + + if observeMetrics then + CacheMetrics.RemoveInstrumentation instanceId + + 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" + + if options.HeadroomPercentage < 0 then + invalidArg "HeadroomPercentage" "HeadroomPercentage must be positive" + + let totalCapacity = Cache.applyOverride options.TotalCapacity + // Determine evictable headroom as the percentage of total capcity, since we want to not resize the dictionary. + let headroom = + int (float options.TotalCapacity * float options.HeadroomPercentage / 100.0) + + let cache = + new Cache<_, _>(totalCapacity, headroom, ?name = name, ?observeMetrics = observeMetrics) + + cache diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi new file mode 100644 index 00000000000..565342bf7f5 --- /dev/null +++ b/src/Compiler/Utilities/Caches.fsi @@ -0,0 +1,44 @@ +namespace FSharp.Compiler.Caches + +open System +open System.Diagnostics.Metrics +open System.Threading + +[] +type internal CacheOptions = + { + /// Total capacity, determines the size of the underlying store. + TotalCapacity: int + + /// Safety margin size as a percentage of TotalCapacity. + HeadroomPercentage: int + } + + static member Default: CacheOptions + +module internal Cache = + val OverrideCapacityForTesting: unit -> unit + +[] +type internal Cache<'Key, 'Value when 'Key: not null and 'Key: equality> = + new: totalCapacity: int * headroom: int * ?name: string * ?observeMetrics: bool -> Cache<'Key, 'Value> + + member TryGetValue: key: 'Key * value: outref<'Value> -> bool + member TryAdd: key: 'Key * value: 'Value -> bool + /// Cancels the background eviction task. + member Dispose: unit -> unit + + interface IDisposable + + /// For testing only + member Evicted: IEvent + + static member Create<'Key, 'Value> : + options: CacheOptions * ?name: string * ?observeMetrics: bool -> Cache<'Key, 'Value> + +[] +type internal CacheMetrics = + static member Meter: Meter + static member GetStats: cacheId: string -> string + /// Retrieves current hit ratio, hits, misses, evictions etc. formatted for printing or logging. + static member GetStatsUpdateForAllCaches: clearCounts: bool -> string diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index bcdface38be..7907c2148dc 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -126,22 +126,6 @@ module HashAccessibility = module rec HashTypes = open Microsoft.FSharp.Core.LanguagePrimitives - let stampEquals g ty1 ty2 = - match (stripTyEqns g ty1), (stripTyEqns g ty2) with - | TType_app(tcref1, _, _), TType_app(tcref2, _, _) -> tcref1.Stamp.Equals(tcref2.Stamp) - | TType_var(r1, _), TType_var(r2, _) -> r1.Stamp.Equals(r2.Stamp) - | _ -> false - - /// Get has for Stamp for TType_app tyconref and TType_var typar - let hashStamp g ty = - let v: Stamp = - match (stripTyEqns g ty) with - | TType_app(tcref, _, _) -> tcref.Stamp - | TType_var(r, _) -> r.Stamp - | _ -> GenericZero - - hash v - /// Hash a reference to a type let hashTyconRef tcref = hashTyconRefImpl tcref @@ -344,3 +328,69 @@ module HashTastMemberOrVals = hashNonMemberVal (g, obs) (tps, vref.Deref, tau, cxs) | Some _ -> hashMember (g, obs) emptyTyparInst vref.Deref + +/// Practical TType comparer strictly for the use with cache keys. +module HashStamps = + let rec typeInstStampsEqual (tys1: TypeInst) (tys2: TypeInst) = + tys1.Length = tys2.Length && (tys1, tys2) ||> Seq.forall2 stampEquals + + and inline typarStampEquals (t1: Typar) (t2: Typar) = t1.Stamp = t2.Stamp + + and typarsStampsEqual (tps1: Typars) (tps2: Typars) = + tps1.Length = tps2.Length && (tps1, tps2) ||> Seq.forall2 typarStampEquals + + and measureStampEquals (m1: Measure) (m2: Measure) = + match m1, m2 with + | Measure.Var(mv1), Measure.Var(mv2) -> mv1.Stamp = mv2.Stamp + | Measure.Const(t1, _), Measure.Const(t2, _) -> t1.Stamp = t2.Stamp + | Measure.Prod(m1, m2, _), Measure.Prod(m3, m4, _) -> measureStampEquals m1 m3 && measureStampEquals m2 m4 + | Measure.Inv m1, Measure.Inv m2 -> measureStampEquals m1 m2 + | Measure.One _, Measure.One _ -> true + | Measure.RationalPower(m1, r1), Measure.RationalPower(m2, r2) -> r1 = r2 && measureStampEquals m1 m2 + | _ -> false + + and nullnessEquals (n1: Nullness) (n2: Nullness) = + match n1, n2 with + | Nullness.Known k1, Nullness.Known k2 -> k1 = k2 + | Nullness.Variable _, Nullness.Variable _ -> true + | _ -> false + + and stampEquals ty1 ty2 = + match ty1, ty2 with + | TType_ucase(u, tys1), TType_ucase(v, tys2) -> u.CaseName = v.CaseName && typeInstStampsEqual tys1 tys2 + | TType_app(tcref1, tinst1, n1), TType_app(tcref2, tinst2, n2) -> + tcref1.Stamp = tcref2.Stamp + && nullnessEquals n1 n2 + && typeInstStampsEqual tinst1 tinst2 + | TType_anon(info1, tys1), TType_anon(info2, tys2) -> info1.Stamp = info2.Stamp && typeInstStampsEqual tys1 tys2 + | TType_tuple(c1, tys1), TType_tuple(c2, tys2) -> c1 = c2 && typeInstStampsEqual tys1 tys2 + | TType_forall(tps1, tau1), TType_forall(tps2, tau2) -> stampEquals tau1 tau2 && typarsStampsEqual tps1 tps2 + | TType_var(r1, n1), TType_var(r2, n2) -> r1.Stamp = r2.Stamp && nullnessEquals n1 n2 + | TType_measure m1, TType_measure m2 -> measureStampEquals m1 m2 + | _ -> false + + let inline hashStamp (x: Stamp) : Hash = uint x * 2654435761u |> int + + // The idea is to keep the illusion of immutability of TType. + // This hash must be stable during compilation, otherwise we won't be able to find keys or evict from the cache. + let rec hashTType ty : Hash = + match ty with + | TType_ucase(u, tinst) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hash u.CaseName) + | TType_app(tcref, tinst, Nullness.Known n) -> + tinst + |> hashListOrderMatters (hashTType) + |> pipeToHash (hashStamp tcref.Stamp) + |> pipeToHash (hash n) + | TType_app(tcref, tinst, Nullness.Variable _) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp tcref.Stamp) + | TType_anon(info, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp info.Stamp) + | TType_tuple(c, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hash c) + | TType_forall(tps, tau) -> + tps + |> Seq.map _.Stamp + |> hashListOrderMatters (hashStamp) + |> pipeToHash (hashTType tau) + | TType_fun(d, r, Nullness.Known n) -> hashTType d |> pipeToHash (hashTType r) |> pipeToHash (hash n) + | TType_fun(d, r, Nullness.Variable _) -> hashTType d |> pipeToHash (hashTType r) + | TType_var(r, Nullness.Known n) -> hashStamp r.Stamp |> pipeToHash (hash n) + | TType_var(r, Nullness.Variable _) -> hashStamp r.Stamp + | TType_measure _ -> 0 diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs new file mode 100644 index 00000000000..3849cd9addd --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs @@ -0,0 +1,90 @@ +module CompilerService.Caches + +open FSharp.Compiler.Caches + +open System.Threading +open Xunit + +[] +let ``Create and dispose many`` () = + let caches = + [ + for _ in 1 .. 100 do + Cache.Create(CacheOptions.Default, observeMetrics = true) + ] + + for c in caches do c.Dispose() + +[] +let ``Create and dispose many named`` () = + let caches = + [ + for i in 1 .. 100 do + Cache.Create(CacheOptions.Default, name = $"testCache{i}", observeMetrics = true) + ] + + for c in caches do c.Dispose() + +[] +let ``Basic add and retrieve`` () = + use cache = Cache.Create(CacheOptions.Default, observeMetrics = true) + + cache.TryAdd("key1", 1) |> ignore + cache.TryAdd("key2", 2) |> ignore + + let mutable value = 0 + Assert.True(cache.TryGetValue("key1", &value), "Should retrieve key1") + Assert.Equal(1, value) + Assert.True(cache.TryGetValue("key2", &value), "Should retrieve key2") + Assert.Equal(2, value) + Assert.False(cache.TryGetValue("key3", &value), "Should not retrieve non-existent key3") + +[] +let ``Eviction of least recently used`` () = + use cache = Cache.Create({ TotalCapacity = 2; HeadroomPercentage = 0 }, observeMetrics = true) + + cache.TryAdd("key1", 1) |> ignore + cache.TryAdd("key2", 2) |> ignore + + // Make key1 recently used by accessing it + let mutable value = 0 + cache.TryGetValue("key1", &value) |> ignore + + let evicted = new ManualResetEvent(false) + cache.Evicted.Add(fun _ -> evicted.Set() |> ignore) + + // Add a third item, which should schedule key2 for eviction + cache.TryAdd("key3", 3) |> ignore + + // Wait for eviction to complete using the event + evicted.WaitOne() |> ignore + + Assert.False(cache.TryGetValue("key2", &value), "key2 should have been evicted") + Assert.True(cache.TryGetValue("key1", &value), "key1 should still be in cache") + Assert.Equal(1, value) + Assert.True(cache.TryGetValue("key3", &value), "key3 should be in cache") + Assert.Equal(3, value) + +[] +let ``Metrics can be retrieved`` () = + use cache = Cache.Create({ TotalCapacity = 2; HeadroomPercentage = 0 }, name = "test_metrics", observeMetrics = true) + + cache.TryAdd("key1", 1) |> ignore + cache.TryAdd("key2", 2) |> ignore + + // Make key1 recently used by accessing it + let mutable value = 0 + cache.TryGetValue("key1", &value) |> ignore + + let evicted = new ManualResetEvent(false) + cache.Evicted.Add(fun _ -> evicted.Set() |> ignore) + + // Add a third item, which should schedule key2 for eviction + cache.TryAdd("key3", 3) |> ignore + + // Wait for eviction to complete using the event + evicted.WaitOne() |> ignore + + let metrics = CacheMetrics.GetStats "test_metrics" + + Assert.Contains("test_metrics | hit ratio", metrics) diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 98eb8a9336c..812833e988c 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -301,6 +301,7 @@ + diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index b17e1b1cd4b..50deb42ea68 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -10,6 +10,7 @@ open Xunit.Abstractions open TestFramework +open FSharp.Compiler.Caches open FSharp.Compiler.Diagnostics open OpenTelemetry.Resources @@ -155,6 +156,7 @@ type OpenTelemetryExport(testRunName, enable) = // Configure OpenTelemetry metrics export. Metrics can be viewed in Prometheus or other compatible tools. OpenTelemetry.Sdk.CreateMeterProviderBuilder() + .AddMeter(CacheMetrics.Meter.Name) .AddMeter("System.Runtime") .ConfigureResource(fun r -> r.AddService(testRunName) |> ignore) .AddOtlpExporter(fun e m -> @@ -185,6 +187,9 @@ type FSharpXunitFramework(sink: IMessageSink) = AssemblyResolver.addResolver () #endif + // Override cache capacity to reduce memory usage in CI. + Cache.OverrideCapacityForTesting() + let testRunName = $"RunTests_{assemblyName.Name} {Runtime.InteropServices.RuntimeInformation.FrameworkDescription}" use _ = new OpenTelemetryExport(testRunName, Environment.GetEnvironmentVariable("FSHARP_OTEL_EXPORT") <> null) diff --git a/vsintegration/src/FSharp.Editor/Common/Logging.fs b/vsintegration/src/FSharp.Editor/Common/Logging.fs index b0f56df3234..de96d46e254 100644 --- a/vsintegration/src/FSharp.Editor/Common/Logging.fs +++ b/vsintegration/src/FSharp.Editor/Common/Logging.fs @@ -30,6 +30,8 @@ module Config = let fsharpOutputGuid = Guid fsharpOutputGuidString open Config +open System.Diagnostics.Metrics +open System.Text [] type Logger [] ([)>] serviceProvider: IServiceProvider) = @@ -118,11 +120,8 @@ module Logging = let logExceptionWithContext (ex: Exception, context) = logErrorf "Context: %s\nException Message: %s\nStack Trace: %s" context ex.Message ex.StackTrace -#if DEBUG -module Activity = - - open OpenTelemetry.Resources - open OpenTelemetry.Trace +module FSharpServiceTelemetry = + open FSharp.Compiler.Caches let listen filter = let indent (activity: Activity) = @@ -135,16 +134,15 @@ module Activity = String.replicate (loop activity 0) " " let collectTags (activity: Activity) = - [ for tag in activity.Tags -> $"{tag.Key}: %A{tag.Value}" ] - |> String.concat ", " + [ for tag in activity.Tags -> $"{tag.Key}: {tag.Value}" ] |> String.concat ", " let listener = new ActivityListener( - ShouldListenTo = (fun source -> source.Name = FSharp.Compiler.Diagnostics.ActivityNames.FscSourceName), + ShouldListenTo = (fun source -> source.Name = ActivityNames.FscSourceName), Sample = (fun context -> if context.Name.Contains(filter) then - ActivitySamplingResult.AllDataAndRecorded + ActivitySamplingResult.AllData else ActivitySamplingResult.None), ActivityStarted = (fun a -> logMsg $"{indent a}{a.OperationName} {collectTags a}") @@ -152,13 +150,56 @@ module Activity = ActivitySource.AddActivityListener(listener) - let export () = - OpenTelemetry.Sdk - .CreateTracerProviderBuilder() - .AddSource(ActivityNames.FscSourceName) - .SetResourceBuilder(ResourceBuilder.CreateDefault().AddService(serviceName = "F#", serviceVersion = "1.0.0")) - .AddOtlpExporter() - .Build() + let logCacheMetricsToOutput () = + + let timer = new System.Timers.Timer(1000.0, AutoReset = true) + + timer.Elapsed.Add(fun _ -> + let stats = CacheMetrics.GetStatsUpdateForAllCaches(clearCounts = true) + + if stats <> "" then + logMsg $"\n{stats}") + + timer.Start() + +#if DEBUG + open OpenTelemetry.Resources + open OpenTelemetry.Trace + open OpenTelemetry.Metrics + + let otelExport () = + // On Windows forwarding localhost to wsl2 docker container sometimes does not work. Use IP address instead. + let otlpEndpoint = Uri("http://127.0.0.1:4317") + + let meterProvider = + // Configure OpenTelemetry metrics. Metrics can be viewed in Prometheus or other compatible tools. + OpenTelemetry.Sdk + .CreateMeterProviderBuilder() + .ConfigureResource(fun r -> r.AddService("F#") |> ignore) + .AddMeter(CacheMetrics.Meter.Name) + .AddMeter("System.Runtime") + .AddOtlpExporter(fun e m -> + e.Endpoint <- otlpEndpoint + m.PeriodicExportingMetricReaderOptions.ExportIntervalMilliseconds <- 1000 + m.TemporalityPreference <- MetricReaderTemporalityPreference.Cumulative) + .Build() + + let tracerProvider = + // Configure OpenTelemetry export. Traces can be viewed in Jaeger or other compatible tools. + OpenTelemetry.Sdk + .CreateTracerProviderBuilder() + .AddSource(ActivityNames.FscSourceName) + .ConfigureResource(fun r -> r.AddService("F#") |> ignore) + .AddOtlpExporter(fun e -> e.Endpoint <- otlpEndpoint) + .Build() + + let a = Activity.startNoTags "FSharpPackage" + + fun () -> + a.Dispose() + tracerProvider.ForceFlush(5000) |> ignore + tracerProvider.Dispose() + meterProvider.Dispose() let listenToAll () = listen "" #endif diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 5cc9cec2943..4eb399a39f3 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -340,15 +340,21 @@ type internal FSharpPackage() as this = let mutable solutionEventsOpt = None -#if DEBUG - let _traceProvider = Logging.Activity.export () - let _logger = Logging.Activity.listenToAll () - // Logging.Activity.listen "IncrementalBuild" -#endif - // FSI-LINKAGE-POINT: unsited init do FSharp.Interactive.Hooks.fsiConsoleWindowPackageCtorUnsited (this :> Package) +#if DEBUG + do Logging.FSharpServiceTelemetry.logCacheMetricsToOutput () + + let flushTelemetry = Logging.FSharpServiceTelemetry.otelExport () + + override this.Dispose(disposing: bool) = + base.Dispose(disposing: bool) + + if disposing then + flushTelemetry () +#endif + override this.InitializeAsync(cancellationToken: CancellationToken, progress: IProgress) : Tasks.Task = // `base.` methods can't be called in the `async` builder, so we have to cache it let baseInitializeAsync = base.InitializeAsync(cancellationToken, progress) diff --git a/vsintegration/tests/FSharp.Editor.Tests/FSharp.Editor.Tests.fsproj b/vsintegration/tests/FSharp.Editor.Tests/FSharp.Editor.Tests.fsproj index 2a760da0f5e..c084fc6f06a 100644 --- a/vsintegration/tests/FSharp.Editor.Tests/FSharp.Editor.Tests.fsproj +++ b/vsintegration/tests/FSharp.Editor.Tests/FSharp.Editor.Tests.fsproj @@ -16,6 +16,9 @@ + + XunitSetup.fs + diff --git a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj index e1e657a651a..395400a795e 100644 --- a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj +++ b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj @@ -16,6 +16,9 @@ + + XunitSetup.fs + diff --git a/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj b/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj index 30a871ad288..c02e6f1bfc7 100644 --- a/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj +++ b/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj @@ -17,6 +17,9 @@ + + XunitSetup.fs +