From 6b0f7d543067edc4229703cf1f90bafabd658b11 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 3 Sep 2025 15:48:41 +0200 Subject: [PATCH 01/29] optimizer --- src/Compiler/Optimize/Optimizer.fs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 52e404cea3e..5aebc9f990b 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/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, From 208362ad9f000be94b376c1216ef79a9cbfa4b21 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 3 Sep 2025 15:49:45 +0200 Subject: [PATCH 02/29] argInfo + implicit yield --- src/Compiler/Checking/CheckBasics.fs | 9 +--- src/Compiler/Checking/CheckBasics.fsi | 8 ---- src/Compiler/Checking/CheckDeclarations.fs | 3 +- .../Checking/Expressions/CheckExpressions.fs | 47 +++++++++---------- 4 files changed, 24 insertions(+), 43 deletions(-) diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index 7cbca970cc3..1b71371b4ea 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/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 + 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 diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index 179752c394c..6c6537d1165 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/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 } 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 diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 07b40b6b119..5b034cd03cf 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/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) -> diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index c5228adeccf..5e79f0b90c7 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/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(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 From 4925224c57a0bef93d456a19b87a3cb629dbda86 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Thu, 4 Sep 2025 09:35:08 +0200 Subject: [PATCH 03/29] fix comment --- src/Compiler/Utilities/Caches.fsi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi index 9ecdcd2a79c..c603af0f841 100644 --- a/src/Compiler/Utilities/Caches.fsi +++ b/src/Compiler/Utilities/Caches.fsi @@ -9,8 +9,8 @@ module internal CacheMetrics = /// Set FSHARP_OTEL_EXPORT environment variable to enable OpenTelemetry export to external collectors in tests. val Meter: Meter -[] /// 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 member GetTotals: unit -> Map From 8d32412af8e1bdfd25a2c2192d42f7e031c6dd3f Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Thu, 4 Sep 2025 19:06:34 +0200 Subject: [PATCH 04/29] see if this helps --- tests/FSharp.Test.Utilities/XunitHelpers.fs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 1823c5a1b6a..33fc874703e 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -195,12 +195,20 @@ type OpenTelemetryExport(testRunName, enable) = // However, we want to ensure that OneTimeSetup is called only once per test run. module OneTimeSetup = + open System.Threading + let init = lazy #if !NETCOREAPP // We need AssemblyResolver already here, because OpenTelemetry loads some assemblies dynamically. log "Adding AssemblyResolver" AssemblyResolver.addResolver () + + // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors + let workers, iocp = ThreadPool.GetMinThreads() + let target = max workers (Environment.ProcessorCount * 4) + if target > workers then + ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From 689112d055827920b68d0afdd306faf6dc8e8b07 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 08:51:07 +0200 Subject: [PATCH 05/29] wip --- src/Compiler/Utilities/Caches.fs | 2 +- tests/FSharp.Test.Utilities/XunitHelpers.fs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 37f93dc298b..0abcaa85103 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -101,7 +101,7 @@ module CacheOptions = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = EvictionMode.MailboxProcessor + CacheOptions.EvictionMode = EvictionMode.Immediate // EvictionMode.MailboxProcessor CacheOptions.Comparer = HashIdentity.Structural } diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 33fc874703e..d12b4bdee04 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -205,10 +205,10 @@ module OneTimeSetup = AssemblyResolver.addResolver () // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors - let workers, iocp = ThreadPool.GetMinThreads() - let target = max workers (Environment.ProcessorCount * 4) - if target > workers then - ThreadPool.SetMinThreads(target, iocp) |> ignore + //let workers, iocp = ThreadPool.GetMinThreads() + //let target = max workers (Environment.ProcessorCount * 4) + //if target > workers then + // ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From 13d4dd14f254bc35cb9e931c04ed984cf546441f Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 09:26:32 +0200 Subject: [PATCH 06/29] Revert "wip" This reverts commit 689112d055827920b68d0afdd306faf6dc8e8b07. --- src/Compiler/Utilities/Caches.fs | 2 +- tests/FSharp.Test.Utilities/XunitHelpers.fs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 0abcaa85103..37f93dc298b 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -101,7 +101,7 @@ module CacheOptions = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = EvictionMode.Immediate // EvictionMode.MailboxProcessor + CacheOptions.EvictionMode = EvictionMode.MailboxProcessor CacheOptions.Comparer = HashIdentity.Structural } diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index d12b4bdee04..33fc874703e 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -205,10 +205,10 @@ module OneTimeSetup = AssemblyResolver.addResolver () // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors - //let workers, iocp = ThreadPool.GetMinThreads() - //let target = max workers (Environment.ProcessorCount * 4) - //if target > workers then - // ThreadPool.SetMinThreads(target, iocp) |> ignore + let workers, iocp = ThreadPool.GetMinThreads() + let target = max workers (Environment.ProcessorCount * 4) + if target > workers then + ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From 7543b439525c9fab69b48b3b6d2773ef4766d76b Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 09:33:48 +0200 Subject: [PATCH 07/29] log min threads --- tests/FSharp.Test.Utilities/XunitHelpers.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 33fc874703e..34ff8fcf0a7 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -208,6 +208,7 @@ module OneTimeSetup = let workers, iocp = ThreadPool.GetMinThreads() let target = max workers (Environment.ProcessorCount * 4) if target > workers then + log $"Increasing ThreadPool minimum worker threads to {target}" ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" From 859fdac05b5ec1adbb668bd3cac626b9c9048be9 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 10:37:05 +0200 Subject: [PATCH 08/29] ? --- tests/FSharp.Test.Utilities/XunitHelpers.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 34ff8fcf0a7..5ed66bb5b57 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -206,7 +206,7 @@ module OneTimeSetup = // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors let workers, iocp = ThreadPool.GetMinThreads() - let target = max workers (Environment.ProcessorCount * 4) + let target = max workers (Environment.ProcessorCount * 2) if target > workers then log $"Increasing ThreadPool minimum worker threads to {target}" ThreadPool.SetMinThreads(target, iocp) |> ignore From 873a9455c5114d384e9c9a1453f72ae1b8cfe541 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 12:28:56 +0200 Subject: [PATCH 09/29] force immediate eviction in some test runs --- azure-pipelines-PR.yml | 3 +++ src/Compiler/Utilities/Caches.fs | 9 +++++++-- tests/FSharp.Test.Utilities/XunitHelpers.fs | 7 ------- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 563f0afcbfb..c7f32eeca37 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -456,11 +456,13 @@ stages: fsharpqa_release: _configuration: Release _testKind: testFSharpQA + FSharp_CacheEvictionImmediate: true transparentCompiler: vs_release: _configuration: Release _testKind: testVs setupVsHive: true + FSharp_CacheEvictionImmediate: true transparentCompiler: transparent_compiler_release: _configuration: Release @@ -681,6 +683,7 @@ stages: clean: true - script: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclr env: + FSharp_CacheEvictionImmediate: true COMPlus_DefaultStackSize: 1000000 displayName: Build / Test - task: PublishTestResults@2 diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 37f93dc298b..af7c5cc3ab5 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -97,11 +97,16 @@ type CacheOptions<'Key> = } module CacheOptions = + let forceImmediate = try Environment.GetEnvironmentVariable("FSharp_CacheEvictionImmediate") <> null with _ -> false + + let defaultEvictionMode = + if forceImmediate then EvictionMode.Immediate else EvictionMode.MailboxProcessor + let getDefault () = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = EvictionMode.MailboxProcessor + CacheOptions.EvictionMode = defaultEvictionMode CacheOptions.Comparer = HashIdentity.Structural } @@ -109,7 +114,7 @@ module CacheOptions = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = EvictionMode.MailboxProcessor + CacheOptions.EvictionMode = defaultEvictionMode CacheOptions.Comparer = HashIdentity.Reference } diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 5ed66bb5b57..6b43e397856 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -203,13 +203,6 @@ module OneTimeSetup = // We need AssemblyResolver already here, because OpenTelemetry loads some assemblies dynamically. log "Adding AssemblyResolver" AssemblyResolver.addResolver () - - // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors - let workers, iocp = ThreadPool.GetMinThreads() - let target = max workers (Environment.ProcessorCount * 2) - if target > workers then - log $"Increasing ThreadPool minimum worker threads to {target}" - ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From 03a606dd51e4aa713bf09f5b9ccc79ce90721ece Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 13:18:06 +0200 Subject: [PATCH 10/29] . --- azure-pipelines-PR.yml | 1 - tests/FSharp.Test.Utilities/XunitHelpers.fs | 7 +++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index c7f32eeca37..67733e21ff5 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -683,7 +683,6 @@ stages: clean: true - script: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclr env: - FSharp_CacheEvictionImmediate: true COMPlus_DefaultStackSize: 1000000 displayName: Build / Test - task: PublishTestResults@2 diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 6b43e397856..5ed66bb5b57 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -203,6 +203,13 @@ module OneTimeSetup = // We need AssemblyResolver already here, because OpenTelemetry loads some assemblies dynamically. log "Adding AssemblyResolver" AssemblyResolver.addResolver () + + // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors + let workers, iocp = ThreadPool.GetMinThreads() + let target = max workers (Environment.ProcessorCount * 2) + if target > workers then + log $"Increasing ThreadPool minimum worker threads to {target}" + ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From e6fc866da4edcad065d0c3d223772b3502f28461 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 13:25:56 +0200 Subject: [PATCH 11/29] . --- azure-pipelines-PR.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 67733e21ff5..cfa5411ee33 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -321,6 +321,7 @@ stages: - script: eng\CIBuildNoPublish.cmd -compressallmetadata -buildnorealsig -testDesktop -configuration Release -testBatch $(System.JobPositionInPhase) env: + FSharp_CacheEvictionImmediate: true DOTNET_DbgEnableMiniDump: 1 DOTNET_DbgMiniDumpType: 3 # Triage dump, 1 for mini, 2 for Heap, 3 for triage, 4 for full. Don't use 4 unless you know what you're doing. DOTNET_DbgMiniDumpName: $(Build.SourcesDirectory)\artifacts\log\Release\$(Build.BuildId)-%e-%p-%t.dmp @@ -561,6 +562,7 @@ stages: - script: eng\CIBuildNoPublish.cmd -compressallmetadata -configuration Release -testDesktop -testBatch $(System.JobPositionInPhase) env: + FSharp_CacheEvictionImmediate: true DOTNET_DbgEnableMiniDump: 1 DOTNET_DbgMiniDumpType: 3 # Triage dump, 1 for mini, 2 for Heap, 3 for triage, 4 for full. Don't use 4 unless you know what you're doing. DOTNET_DbgMiniDumpName: $(Build.SourcesDirectory)\artifacts\log\Release\$(Build.BuildId)-%e-%p-%t.dmp From 4d69ae52a608e53f81b8fb9bd3c8a667c80c7481 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 14:45:16 +0200 Subject: [PATCH 12/29] format --- src/Compiler/Utilities/Caches.fs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index af7c5cc3ab5..9a2631991e1 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -97,10 +97,17 @@ type CacheOptions<'Key> = } module CacheOptions = - let forceImmediate = try Environment.GetEnvironmentVariable("FSharp_CacheEvictionImmediate") <> null with _ -> false + let forceImmediate = + try + Environment.GetEnvironmentVariable("FSharp_CacheEvictionImmediate") <> null + with _ -> + false let defaultEvictionMode = - if forceImmediate then EvictionMode.Immediate else EvictionMode.MailboxProcessor + if forceImmediate then + EvictionMode.Immediate + else + EvictionMode.MailboxProcessor let getDefault () = { From 942640bda1482bba396395bc0c8206da4ec0b219 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Fri, 5 Sep 2025 16:22:43 +0200 Subject: [PATCH 13/29] . --- tests/FSharp.Test.Utilities/XunitHelpers.fs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 5ed66bb5b57..6b43e397856 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -203,13 +203,6 @@ module OneTimeSetup = // We need AssemblyResolver already here, because OpenTelemetry loads some assemblies dynamically. log "Adding AssemblyResolver" AssemblyResolver.addResolver () - - // Increase worker threads to mitigate temporary starvation from many caches with MailboxProcessors - let workers, iocp = ThreadPool.GetMinThreads() - let target = max workers (Environment.ProcessorCount * 2) - if target > workers then - log $"Increasing ThreadPool minimum worker threads to {target}" - ThreadPool.SetMinThreads(target, iocp) |> ignore #endif log "Installing TestConsole redirection" TestConsole.install() From aac2a46851379e2eca40568c56be5d48d693b79a Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Tue, 9 Sep 2025 19:52:39 +0200 Subject: [PATCH 14/29] add a test --- .../FSharp.Compiler.ComponentTests.fsproj | 1 + .../Optimizer/NestedApplications.fs | 64 +++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 960057baf98..78d9fa0020d 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -351,6 +351,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs new file mode 100644 index 00000000000..178f273d168 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs @@ -0,0 +1,64 @@ +namespace FSharp.Compiler.ComponentTests.Optimizer + +open System.Text +open Xunit +open FSharp.Test +open FSharp.Test.Compiler +open FSharp.Test.Utilities + +module private Gen = + let nestedLetApps depth = + // Builds: let v1 = id 0 in let v2 = id v1 in ... in ignore vN + let sb = StringBuilder() + sb.AppendLine("module M") |> ignore + sb.AppendLine("let id x = x") |> ignore + sb.AppendLine("let run () =") |> ignore + for i in 1 .. depth do + if i = 1 then + sb.Append(" let v1 = id 0") |> ignore + else + sb.Append(" in let v").Append(i).Append(" = id v").Append(i-1) |> ignore + sb.AppendLine(" in ()") |> ignore + sb.ToString() + + let nestedDirectApps depth = + // Builds: let res = id(id(id(...(0)))) in ignore res + let sb = StringBuilder() + sb.AppendLine("module N") |> ignore + sb.AppendLine("let id x = x") |> ignore + sb.Append("let run () = let res = ") |> ignore + for _ in 1 .. depth do + sb.Append("id (") |> ignore + sb.Append("0") |> ignore + for _ in 1 .. depth do + sb.Append(")") |> ignore + sb.AppendLine(" in ignore res") |> ignore + sb.ToString() + +[] +type ``Nested application optimizer``() = + + // Moderate depths to keep CI stable while still exercising the quadratic shapes + [] + [] + [] + let ``let-chains of nested apps compile under --optimize+`` depth = + let src = Gen.nestedLetApps depth + FSharp src + |> withOptions [ "--optimize+"; "--times" ] + |> asExe + |> ignoreWarnings + |> compile + |> shouldSucceed + + [] + [] + [] + let ``direct nested application compiles under --optimize+`` depth = + let src = Gen.nestedDirectApps depth + FSharp src + |> withOptions [ "--optimize+"; "--times" ] + |> asExe + |> ignoreWarnings + |> compile + |> shouldSucceed \ No newline at end of file From 57c8f3f23e32624b7296a5f08b5cc3c3c19f717d Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Tue, 9 Sep 2025 21:09:40 +0200 Subject: [PATCH 15/29] restore optimizer --- src/Compiler/Optimize/Optimizer.fs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 5aebc9f990b..52e404cea3e 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -9,7 +9,6 @@ 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 @@ -37,10 +36,6 @@ 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 @@ -2903,11 +2898,10 @@ 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? - let collect expr = (freeInExpr (CollectLocalsWithStackGuard()) expr).FreeLocals - if ValueIsUsedOrHasEffect cenv (fun () -> (getFreeLocalsCache cenv).GetOrAdd(bodyR, collect)) (bindR, bindingInfo) then + if ValueIsUsedOrHasEffect cenv (fun () -> (freeInExpr (CollectLocalsWithStackGuard()) bodyR).FreeLocals) (bindR, bindingInfo) then // Eliminate let bindings on the way back up let exprR, adjust = TryEliminateLet cenv env bindR bodyR m exprR, From 078b49f7ed740339d1ec4993c8e28e38642627f5 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 10 Sep 2025 22:28:28 +0200 Subject: [PATCH 16/29] additional type rel caches --- src/Compiler/Checking/TypeRelations.fs | 116 ++++++++++++++++++------- 1 file changed, 84 insertions(+), 32 deletions(-) diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 3943455c6bd..51c163a4608 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -40,6 +40,38 @@ let getTypeSubsumptionCache = new Caches.Cache(options, "typeSubsumptionCache") Extras.WeakMap.getOrCreate factory +// Cache for feasible equivalence checks +[] +type TTypeFeasibleEquivCacheKey = + | TTypeFeasibleEquivCacheKey of TypeStructure * TypeStructure * bool + static member FromStrippedTypes(stripMeasures: bool, ty1: TType, ty2: TType) = + TTypeFeasibleEquivCacheKey(getTypeStructure ty1, getTypeStructure ty2, stripMeasures) + +let getTypeFeasibleEquivCache = + 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 } + new Caches.Cache(options, "typeFeasibleEquivCache") + Extras.WeakMap.getOrCreate factory + +// Cache for definite subsumption without coercion +[] +type TTypeDefinitelySubsumesNoCoerceCacheKey = + | TTypeDefinitelySubsumesNoCoerceCacheKey of TypeStructure * TypeStructure + static member FromStrippedTypes(ty1: TType, ty2: TType) = + TTypeDefinitelySubsumesNoCoerceCacheKey(getTypeStructure ty1, getTypeStructure ty2) + +let getTypeDefinitelySubsumesNoCoerceCache = + 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 } + new Caches.Cache(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. // @@ -59,20 +91,28 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 = else 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)))) + let checkSubsumes () = + // 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.FromStrippedTypes(ty1, ty2) + (getTypeDefinitelySubsumesNoCoerceCache g).GetOrAdd(key, fun _ -> checkSubsumes ()) + else + checkSubsumes () let stripAll stripMeasures g ty = if stripMeasures then @@ -89,30 +129,42 @@ 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 cache = getTypeFeasibleEquivCache g + let key1 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty1, ty2) + let res = cache.GetOrAdd(key1, fun _ -> computeEquiv ty1 ty2) + // Cache the symmetric result as well since this relation is symmetric + let key2 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty2, ty1) + cache.GetOrAdd(key2, fun _ -> res) |> ignore + res + else + computeEquiv ty1 ty2 /// The feasible equivalence relation. Part of the language spec. let TypesFeasiblyEquiv ndeep g amap m ty1 ty2 = From 128e84775658d8faca965e31e1a5c2478a4ccf41 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Sun, 14 Sep 2025 22:39:24 +0200 Subject: [PATCH 17/29] while loop --- src/Compiler/Utilities/Caches.fs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 9a2631991e1..62935383ab9 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -244,14 +244,11 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke let startEvictionProcessor ct = MailboxProcessor.Start( (fun mb -> - let rec processNext () = - async { + async { + while true do let! message = mb.Receive() processEvictionMessage message - return! processNext () - } - - processNext ()), + }), ct ) From f6c331990371566d780bbc8f45f44814d212c796 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 17:28:00 +0200 Subject: [PATCH 18/29] don't unload ad --- tests/FSharp.Test.Utilities/CompilerAssert.fs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/tests/FSharp.Test.Utilities/CompilerAssert.fs b/tests/FSharp.Test.Utilities/CompilerAssert.fs index d7c910e05f9..f13e11decca 100644 --- a/tests/FSharp.Test.Utilities/CompilerAssert.fs +++ b/tests/FSharp.Test.Utilities/CompilerAssert.fs @@ -376,7 +376,7 @@ module CompilerAssertHelpers = let setup = AppDomainSetup(ApplicationBase = thisAssemblyDirectory) let testCaseDomain = AppDomain.CreateDomain($"built app {assembly}", null, setup) - testCaseDomain.add_AssemblyResolve(fun _ args -> + let handler = ResolveEventHandler(fun _ args -> dependecies |> List.tryFind (fun path -> Path.GetFileNameWithoutExtension path = AssemblyName(args.Name).Name) |> Option.filter FileSystem.FileExistsShim @@ -384,6 +384,8 @@ module CompilerAssertHelpers = |> Option.toObj ) + testCaseDomain.add_AssemblyResolve handler + let worker = (testCaseDomain.CreateInstanceFromAndUnwrap(typeof.Assembly.CodeBase, typeof.FullName)) :?> Worker @@ -391,8 +393,8 @@ module CompilerAssertHelpers = // Replay streams captured in appdomain. printf $"{output}" eprintf $"{errors}" - - AppDomain.Unload testCaseDomain + + testCaseDomain.remove_AssemblyResolve handler outcome, output, errors From 62dc77ff7acd8bd78c16a446d4f056cb8db87b80 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 17:28:36 +0200 Subject: [PATCH 19/29] server gc in netcore tests --- tests/Directory.Build.props | 1 + tests/FSharp.Test.Utilities/XunitHelpers.fs | 1 + 2 files changed, 2 insertions(+) diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index c2f0cf4bed4..4e5c4f25528 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -16,6 +16,7 @@ false false true + true diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 6b43e397856..74e982b4a37 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -204,6 +204,7 @@ module OneTimeSetup = log "Adding AssemblyResolver" AssemblyResolver.addResolver () #endif + log $"Server GC enabled: {System.Runtime.GCSettings.IsServerGC}" log "Installing TestConsole redirection" TestConsole.install() From 930d871adfe9134d2c723745bcfdfd83f16e9f7a Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 17:29:25 +0200 Subject: [PATCH 20/29] collect stats better --- src/Compiler/Utilities/Caches.fs | 175 ++++++++++++------ src/Compiler/Utilities/Caches.fsi | 16 +- .../CompilerService/Caches.fs | 15 +- 3 files changed, 130 insertions(+), 76 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 62935383ab9..5a82ecf6d51 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -22,57 +22,103 @@ module CacheMetrics = let creations = Meter.CreateCounter("creations", "count") let disposals = Meter.CreateCounter("disposals", "count") - let mkTag name = KeyValuePair<_, obj>("name", name) - - 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) - -// 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 incr key v = - Interlocked.Add(totals[key], v) |> ignore - - let total key = totals[key].Value - - let mutable ratio = Double.NaN + let mutable private nextCacheId = 0 + + let mkTags (name: string) = + let cacheId = Interlocked.Increment &nextCacheId + [| "name", box name; "cacheId", box cacheId |] + |> Array.map KeyValuePair + |> TagList + + let Add (tags: inref) = adds.Add(1L, &tags) + let Update (tags: inref) = updates.Add(1L, &tags) + let Hit (tags: inref) = hits.Add(1L, &tags) + let Miss (tags: inref) = misses.Add(1L, &tags) + let Eviction (tags: inref) = evictions.Add(1L, &tags) + let EvictionFail (tags: inref) = evictionFails.Add(1L, &tags) + let Created (tags: inref) = creations.Add(1L, &tags) + let Disposed (tags: inref) = disposals.Add(1L, &tags) + + type Stats() = + let totals = Map [ for counter in allCounters -> counter.Name, ref 0L ] + let total key = totals[key].Value + + let mutable ratio = Double.NaN + + let updateRatio () = + ratio <- + float (total hits.Name) + / float (total hits.Name + total misses.Name) + + member _.Incr key v = + assert (totals.ContainsKey key) + Interlocked.Add(totals[key], v) |> ignore + + if key = hits.Name || key = misses.Name then + updateRatio () + + 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() + + let getStatsByName name = statsByName.GetOrAdd(name, fun _ -> Stats ()) + + let ListenToAll () = + let listener = new MeterListener() + for instrument in allCounters do + listener.EnableMeasurementEvents instrument + listener.SetMeasurementEventCallback(fun instrument v tags _ -> + match tags[0].Value with + | :? string as name -> + let stats = getStatsByName name + stats.Incr instrument.Name v + | _ -> assert false) + listener.Start() - let updateRatio () = - ratio <- - float (total CacheMetrics.hits.Name) - / float (total CacheMetrics.hits.Name + total CacheMetrics.misses.Name) + let StatsToString () = + let sb = Text.StringBuilder() + sb.AppendLine "Cache Metrics:" |> ignore + for kv in statsByName do + sb.AppendLine $"Cache {kv.Key}: {kv.Value}" |> ignore + sb.AppendLine() |> ignore + string sb - let listener = new MeterListener() + // 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) = - do + let stats = Stats() + let listener = new MeterListener() - for instrument in CacheMetrics.allCounters do - listener.EnableMeasurementEvents instrument + do + for instrument in allCounters do + listener.EnableMeasurementEvents instrument - listener.SetMeasurementEventCallback(fun instrument v tags _ -> - if tags[0] = tag then - incr instrument.Name v + listener.SetMeasurementEventCallback(fun instrument v tags _ -> + let tagsMatch = tags[0] = cacheTags[0] && tags[1] = cacheTags[1] + if tagsMatch then stats.Incr instrument.Name v) - if instrument = CacheMetrics.hits || instrument = CacheMetrics.misses then - updateRatio ()) + listener.Start() - listener.Start() + interface IDisposable with + member _.Dispose() = listener.Dispose() - interface IDisposable with - member _.Dispose() = listener.Dispose() + member _.GetTotals() = stats.GetTotals() - member _.GetTotals() = - [ for k in totals.Keys -> k, total k ] |> Map.ofList + member _.Ratio = stats.Ratio - member _.GetStats() = [ "hit-ratio", ratio ] |> Map.ofList + override _.ToString() = stats.ToString() [] type EvictionMode = @@ -163,7 +209,7 @@ type EvictionQueueMessage<'Entity, 'Target> = | Update of 'Entity [] -[] +[] type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Key>, ?name) = do @@ -190,7 +236,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 @@ -223,10 +269,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 @@ -244,11 +290,14 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke let startEvictionProcessor ct = MailboxProcessor.Start( (fun mb -> - async { - while true do + let rec processNext () = + async { let! message = mb.Receive() processEvictionMessage message - }), + return! processNext () + } + + processNext ()), ct ) @@ -271,7 +320,11 @@ 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 @@ -279,12 +332,12 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke 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 @@ -294,7 +347,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 @@ -311,11 +364,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 @@ -330,18 +383,18 @@ 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() = @@ -350,3 +403,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 index c603af0f841..2d4d198e745 100644 --- a/src/Compiler/Utilities/Caches.fsi +++ b/src/Compiler/Utilities/Caches.fsi @@ -8,13 +8,15 @@ 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 -> unit + val StatsToString: unit -> string -/// 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 - member GetTotals: unit -> Map - interface IDisposable + /// A local listener that can be created for a specific Cache instance to get its metrics. For testing purposes only. + [] + type internal CacheMetricsListener = + member Ratio: float + member GetTotals: unit -> Map + interface IDisposable [] type internal EvictionMode = @@ -64,4 +66,4 @@ type internal Cache<'Key, 'Value when 'Key: not null> = /// For testing only. member EvictionFailed: IEvent /// 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 index 27cedae59de..6ec09944926 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs @@ -133,10 +133,9 @@ let ``Metrics can be retrieved`` () = cache.TryAdd("key3", 3) |> shouldBeTrue evictionCompleted.Task.Wait shouldNeverTimeout |> shouldBeTrue - let stats = metricsListener.GetStats() let totals = metricsListener.GetTotals() - stats.["hit-ratio"] |> shouldEqual 1.0 + metricsListener.Ratio |> shouldEqual 1.0 totals.["evictions"] |> shouldEqual 1L totals.["adds"] |> shouldEqual 3L @@ -156,11 +155,10 @@ let ``GetOrAdd basic usage`` () = v3 |> shouldEqual 4 factoryCalls |> shouldEqual 2 // Metrics assertions - let stats = metricsListener.GetStats() let totals = metricsListener.GetTotals() totals.["hits"] |> shouldEqual 1L totals.["misses"] |> shouldEqual 2L - stats.["hit-ratio"] |> shouldEqual (1.0/3.0) + metricsListener.Ratio |> shouldEqual (1.0/3.0) totals.["adds"] |> shouldEqual 2L [] @@ -179,11 +177,10 @@ let ``AddOrUpdate basic usage`` () = cache.TryGetValue("y", &value) |> shouldBeTrue value |> shouldEqual 99 // Metrics assertions - let stats = metricsListener.GetStats() let totals = metricsListener.GetTotals() totals.["hits"] |> shouldEqual 3L // 3 cache hits totals.["misses"] |> shouldEqual 0L // 0 cache misses - stats.["hit-ratio"] |> shouldEqual 1.0 + metricsListener.Ratio |> shouldEqual 1.0 totals.["adds"] |> shouldEqual 2L // "x" and "y" added totals.["updates"] |> shouldEqual 1L // "x" updated @@ -220,11 +217,10 @@ let ``GetOrAdd with reference identity`` () = v1'' |> shouldEqual v1' v2'' |> shouldEqual v2' // Metrics assertions - let stats = metricsListener.GetStats() let totals = metricsListener.GetTotals() totals.["hits"] |> shouldEqual 4L totals.["misses"] |> shouldEqual 3L - stats.["hit-ratio"] |> shouldEqual (4.0 / 7.0) + metricsListener.Ratio |> shouldEqual (4.0 / 7.0) totals.["adds"] |> shouldEqual 2L [] @@ -250,10 +246,9 @@ let ``AddOrUpdate with reference identity`` () = cache.TryGetValue(t1, &value1Updated) |> shouldBeTrue value1Updated |> shouldEqual 9 // Metrics assertions - let stats = metricsListener.GetStats() let totals = metricsListener.GetTotals() totals.["hits"] |> shouldEqual 3L // 3 cache hits totals.["misses"] |> shouldEqual 0L // 0 cache misses - stats.["hit-ratio"] |> shouldEqual 1.0 + metricsListener.Ratio |> shouldEqual 1.0 totals.["adds"] |> shouldEqual 2L // t1 and t2 added totals.["updates"] |> shouldEqual 1L // t1 updated once From af601bb7a8620464a71458e12355b6edc88cb337 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 17:29:55 +0200 Subject: [PATCH 21/29] show stats in vs output pane --- .../src/FSharp.Editor/Common/DebugHelpers.fs | 31 ++++++++----------- .../LanguageService/LanguageService.fs | 2 ++ 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs index 6ffb3cd7d95..79174a7ca82 100644 --- a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs @@ -56,29 +56,16 @@ module FSharpOutputPane = let private log logType msg = task { System.Diagnostics.Trace.TraceInformation(msg) - let time = DateTime.Now.ToString("hh:mm:ss tt") - let! pane = pane.GetValueAsync() do! ThreadHelper.JoinableTaskFactory.SwitchToMainThreadAsync() match logType with - | LogType.Message -> - String.Format("[{0}{1}] {2}{3}", "", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Info -> - String.Format("[{0}{1}] {2}{3}", "INFO ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Warn -> - String.Format("[{0}{1}] {2}{3}", "WARN ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Error -> - String.Format("[{0}{1}] {2}{3}", "ERROR ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore + | LogType.Message -> $"{msg}" + | LogType.Info -> $"[INFO] {msg}" + | LogType.Warn -> $"[WARN] {msg}" + | LogType.Error -> $"[ERROR] {msg}" + |> pane.OutputStringThreadSafe |> ignore } |> ignore @@ -102,6 +89,7 @@ module FSharpOutputPane = module FSharpServiceTelemetry = open FSharp.Compiler.Caches + open System.Threading.Tasks let listen filter = let indent (activity: Activity) = @@ -130,6 +118,13 @@ module FSharpServiceTelemetry = ActivitySource.AddActivityListener(listener) + let periodicallyDisplayCacheStats() = backgroundTask { + CacheMetrics.ListenToAll() + while true do + do! Task.Delay(TimeSpan.FromSeconds 10.0) + FSharpOutputPane.logMsg (CacheMetrics.StatsToString()) + } + #if DEBUG open OpenTelemetry.Resources open OpenTelemetry.Trace diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 08318997477..00edbdd6a86 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -407,6 +407,8 @@ type internal FSharpPackage() as this = globalOptions.BlockForCompletionItems <- false + DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats() |> ignore + } |> CancellableTask.startAsTask cancellationToken) ) From 66a5ba71646a67a2943fce278b80e6fbabc567ff Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 20:51:44 +0200 Subject: [PATCH 22/29] fix method missing at runtime - ns2.0 haha --- src/Compiler/Utilities/Caches.fs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 5a82ecf6d51..6bb9b29338b 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -26,9 +26,11 @@ module CacheMetrics = let mkTags (name: string) = let cacheId = Interlocked.Increment &nextCacheId - [| "name", box name; "cacheId", box cacheId |] - |> Array.map KeyValuePair - |> TagList + // Avoid TagList(ReadOnlySpan<...>) to support net472 runtime + let mutable tags = TagList() + tags.Add("name", box name) + tags.Add("cacheId", box cacheId) + tags let Add (tags: inref) = adds.Add(1L, &tags) let Update (tags: inref) = updates.Add(1L, &tags) From bd7c24d53804ec0de5259d216f872c7df08ce665 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Wed, 17 Sep 2025 23:16:46 +0200 Subject: [PATCH 23/29] format --- src/Compiler/Utilities/Caches.fs | 34 ++++++++++++------- .../src/FSharp.Editor/Common/DebugHelpers.fs | 17 ++++++---- .../LanguageService/LanguageService.fs | 2 +- 3 files changed, 33 insertions(+), 20 deletions(-) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 6bb9b29338b..1c21cf12bd6 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -46,11 +46,9 @@ module CacheMetrics = let total key = totals[key].Value let mutable ratio = Double.NaN - + let updateRatio () = - ratio <- - float (total hits.Name) - / float (total hits.Name + total misses.Name) + ratio <- float (total hits.Name) / float (total hits.Name + total misses.Name) member _.Incr key v = assert (totals.ContainsKey key) @@ -66,33 +64,42 @@ module CacheMetrics = 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}" ] + [ + 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() - let getStatsByName name = statsByName.GetOrAdd(name, fun _ -> Stats ()) + let getStatsByName name = + statsByName.GetOrAdd(name, fun _ -> Stats()) let ListenToAll () = let listener = new MeterListener() + for instrument in allCounters do listener.EnableMeasurementEvents instrument + listener.SetMeasurementEventCallback(fun instrument v tags _ -> match tags[0].Value with | :? string as name -> let stats = getStatsByName name stats.Incr instrument.Name v | _ -> assert false) + listener.Start() let StatsToString () = let sb = Text.StringBuilder() sb.AppendLine "Cache Metrics:" |> ignore + for kv in statsByName do sb.AppendLine $"Cache {kv.Key}: {kv.Value}" |> ignore + sb.AppendLine() |> ignore string sb @@ -109,7 +116,9 @@ module CacheMetrics = listener.SetMeasurementEventCallback(fun instrument v tags _ -> let tagsMatch = tags[0] = cacheTags[0] && tags[1] = cacheTags[1] - if tagsMatch then stats.Incr instrument.Name v) + + if tagsMatch then + stats.Incr instrument.Name v) listener.Start() @@ -366,7 +375,7 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke if wasMiss then post (EvictionQueueMessage.Add(result, store)) - CacheMetrics.Add &tags + CacheMetrics.Add &tags CacheMetrics.Miss &tags else post (EvictionQueueMessage.Update result) @@ -391,7 +400,8 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke CacheMetrics.Update &tags post (EvictionQueueMessage.Update result) - member _.CreateMetricsListener() = new CacheMetrics.CacheMetricsListener(tags) + member _.CreateMetricsListener() = + new CacheMetrics.CacheMetricsListener(tags) member _.Dispose() = if Interlocked.Exchange(&disposed, 1) = 0 then diff --git a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs index 79174a7ca82..a4ec303ddf2 100644 --- a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs @@ -65,7 +65,8 @@ module FSharpOutputPane = | LogType.Info -> $"[INFO] {msg}" | LogType.Warn -> $"[WARN] {msg}" | LogType.Error -> $"[ERROR] {msg}" - |> pane.OutputStringThreadSafe |> ignore + |> pane.OutputStringThreadSafe + |> ignore } |> ignore @@ -118,12 +119,14 @@ module FSharpServiceTelemetry = ActivitySource.AddActivityListener(listener) - let periodicallyDisplayCacheStats() = backgroundTask { - CacheMetrics.ListenToAll() - while true do - do! Task.Delay(TimeSpan.FromSeconds 10.0) - FSharpOutputPane.logMsg (CacheMetrics.StatsToString()) - } + let periodicallyDisplayCacheStats () = + backgroundTask { + CacheMetrics.ListenToAll() + + while true do + do! Task.Delay(TimeSpan.FromSeconds 10.0) + FSharpOutputPane.logMsg (CacheMetrics.StatsToString()) + } #if DEBUG open OpenTelemetry.Resources diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 00edbdd6a86..9ff5915a1dd 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -407,7 +407,7 @@ type internal FSharpPackage() as this = globalOptions.BlockForCompletionItems <- false - DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats() |> ignore + DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats () |> ignore } |> CancellableTask.startAsTask cancellationToken) From c3083439f6d468c7a4917189d99b4cf7a720a2a1 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Thu, 18 Sep 2025 22:35:45 +0200 Subject: [PATCH 24/29] better formatting of stats --- src/Compiler/Driver/fsc.fs | 1 + src/Compiler/Utilities/Caches.fs | 50 +++++++++++++++++-- src/Compiler/Utilities/Caches.fsi | 3 +- .../src/FSharp.Editor/Common/DebugHelpers.fs | 8 +-- .../LanguageService/LanguageService.fs | 3 +- 5 files changed, 55 insertions(+), 10 deletions(-) diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index 2ef07e66e6b..2bea066e427 100644 --- 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 index 1c21cf12bd6..630732b4f66 100644 --- 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") @@ -92,16 +93,55 @@ module CacheMetrics = | _ -> assert false) listener.Start() + listener :> IDisposable let StatsToString () = - let sb = Text.StringBuilder() - sb.AppendLine "Cache Metrics:" |> ignore + use sw = new StringWriter() + + let nameColumnWidth = + [ yield! statsByName.Keys; "Cache name" ] |> Seq.map String.length |> Seq.max + + let ratioColumnWidth = "hit-ratio".Length + let columns = allCounters |> List.map _.Name + let columnWidths = columns |> List.map String.length |> List.map (max 8) + + let totalWidth = + 1 + nameColumnWidth :: ratioColumnWidth :: columnWidths + |> List.map ((+) 3) + |> List.sum + + sw.WriteLine(String('-', totalWidth)) + let cacheNameHeader = "Cache name".PadRight nameColumnWidth + sw.Write $"| {cacheNameHeader} | hit-ratio |" + + for w, c in (columnWidths, columns) ||> List.zip do + sw.Write $" {c.PadLeft w} |" + + sw.WriteLine() + sw.WriteLine(String('-', totalWidth)) for kv in statsByName do - sb.AppendLine $"Cache {kv.Key}: {kv.Value}" |> ignore + let name = kv.Key + let stats = kv.Value + let totals = stats.GetTotals() + sw.Write $"| {name.PadLeft nameColumnWidth} | {stats.Ratio, 9:P2} |" - sb.AppendLine() |> ignore - string sb + for w, c in (columnWidths, columns) ||> List.zip do + sw.Write $" {totals[c].ToString().PadLeft(w)} |" + + sw.WriteLine() + + sw.WriteLine(String('-', totalWidth)) + string sw + + let CaptureStatsAndWriteToConsole () = + let listener = ListenToAll() + + { new IDisposable with + member _.Dispose() = + listener.Dispose() + Console.WriteLine(StatsToString()) + } // 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. diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi index 2d4d198e745..a85aeb1d33a 100644 --- a/src/Compiler/Utilities/Caches.fsi +++ b/src/Compiler/Utilities/Caches.fsi @@ -8,8 +8,9 @@ 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 -> unit + val ListenToAll: unit -> IDisposable val StatsToString: unit -> string + val CaptureStatsAndWriteToConsole: unit -> IDisposable /// A local listener that can be created for a specific Cache instance to get its metrics. For testing purposes only. [] diff --git a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs index a4ec303ddf2..256bfbed2c6 100644 --- a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs @@ -31,6 +31,7 @@ open Config open System.Diagnostics.Metrics open System.Text open Microsoft.VisualStudio.Threading +open Microsoft.VisualStudio.FSharp.Editor.CancellableTasks module FSharpOutputPane = @@ -119,14 +120,15 @@ module FSharpServiceTelemetry = ActivitySource.AddActivityListener(listener) - let periodicallyDisplayCacheStats () = - backgroundTask { - CacheMetrics.ListenToAll() + let periodicallyDisplayCacheStats (disposalToken: Threading.CancellationToken) = + cancellableTask { + use _ = CacheMetrics.ListenToAll() while true do do! Task.Delay(TimeSpan.FromSeconds 10.0) FSharpOutputPane.logMsg (CacheMetrics.StatsToString()) } + |> CancellableTask.start disposalToken #if DEBUG open OpenTelemetry.Resources diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 9ff5915a1dd..afa9a961e53 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -407,7 +407,8 @@ type internal FSharpPackage() as this = globalOptions.BlockForCompletionItems <- false - DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats () |> ignore + DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats this.DisposalToken + |> ignore } |> CancellableTask.startAsTask cancellationToken) From 0e32a4bedd46241e6847f3fd51f31b23c44a8e14 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Sat, 20 Sep 2025 10:25:18 +0200 Subject: [PATCH 25/29] use immutable array --- src/Compiler/Utilities/TypeHashing.fs | 34 +++++++++++++++++++++------ 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index 0f7d4740bb6..20e57e64f42 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -9,6 +9,7 @@ open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open System.Collections.Immutable +open System type ObserverVisibility = | PublicOnly @@ -397,10 +398,29 @@ module StructuralUtilities = | Nullness of nullness: NullnessInfo | TupInfo of b: bool | MeasureOne - | MeasureRational of rational: Rational + | MeasureRational of Rational | NeverEqual of never: NeverEqual - type TypeStructure = TypeToken[] + [] + type TypeStructure = + | TypeStructure of hash: int * tokens: ImmutableArray + + static member inline FromTokens(tokens: ImmutableArray) = + // We might as well precompute the hash, because this is only going to be used as a key. + TypeStructure(hash tokens, tokens) + + override this.GetHashCode() = let (TypeStructure(h, _)) = this in h + + interface System.IEquatable with + member this.Equals that = + let (TypeStructure(h1, tokens1)) = this + let (TypeStructure(h2, tokens2)) = that + h1 = h2 && tokens1 = tokens2 + + override this.Equals that = + match that with + | :? TypeStructure as that -> (this :> IEquatable<_>).Equals that + | _ -> false [] let private initialTokenCapacity = 4 @@ -410,7 +430,7 @@ module StructuralUtilities = | ValueSome k -> TypeToken.Nullness k | _ -> TypeToken.NeverEqual NeverEqual.Singleton - let rec private accumulateMeasure (tokens: ResizeArray) (m: Measure) = + let rec private accumulateMeasure (tokens: ImmutableArray.Builder) (m: Measure) = match m with | Measure.Var mv -> tokens.Add(TypeToken.Stamp mv.Stamp) | Measure.Const(tcref, _) -> tokens.Add(TypeToken.Stamp tcref.Stamp) @@ -423,7 +443,7 @@ module StructuralUtilities = accumulateMeasure tokens m1 tokens.Add(TypeToken.MeasureRational r) - let rec private accumulateTType (tokens: ResizeArray) (ty: TType) = + let rec private accumulateTType (tokens: ImmutableArray<_>.Builder ) (ty: TType) = match ty with | TType_ucase(u, tinst) -> tokens.Add(TypeToken.Stamp u.TyconRef.Stamp) @@ -462,7 +482,7 @@ module StructuralUtilities = | TType_measure m -> accumulateMeasure tokens m /// Get the full structure of a type as a sequence of tokens, suitable for equality - let getTypeStructure ty = - let tokens = ResizeArray(initialTokenCapacity) + let inline getTypeStructure ty = + let tokens = ImmutableArray.CreateBuilder(initialTokenCapacity) accumulateTType tokens ty - tokens.ToArray() + tokens.ToImmutable() |> TypeStructure.FromTokens From 8b4738e559321362ad700b41ac50a3c5cef9f4f5 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Sat, 20 Sep 2025 14:56:06 +0200 Subject: [PATCH 26/29] MemoizationTable backed by Cache --- .../Checking/Expressions/CheckExpressions.fs | 2 +- src/Compiler/Checking/InfoReader.fs | 28 +++++++++---------- src/Compiler/Checking/TypeRelations.fs | 12 ++++---- src/Compiler/CodeGen/IlxGen.fs | 1 + src/Compiler/FSharp.Compiler.Service.fsproj | 4 +-- src/Compiler/TypedTree/TcGlobals.fs | 2 +- src/Compiler/Utilities/Caches.fs | 12 ++------ src/Compiler/Utilities/Caches.fsi | 2 +- src/Compiler/Utilities/illib.fs | 9 ++++-- src/Compiler/Utilities/illib.fsi | 2 +- .../CompilerService/Caches.fs | 18 ++++++------ 11 files changed, 46 insertions(+), 46 deletions(-) diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 9128371a714..c3a70cb70e8 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -956,7 +956,7 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData, retData) as sigMD) = sigMD let getArgInfoCache = - let options = Caches.CacheOptions.getDefault() |> Caches.CacheOptions.withNoEviction + let options = Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction let factory _ = new Caches.Cache<_, ArgReprInfo>(options, "argInfoCache") WeakMap.getOrCreate factory diff --git a/src/Compiler/Checking/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index b8a0efd14af..6a17b25136e 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -727,9 +727,9 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = /// Make a cache for function 'f' keyed by type (plus some additional 'flags') that only /// caches computations for monomorphic types. - let MakeInfoCache f (flagsEq : IEqualityComparer<_>) = + let MakeInfoCache name f (flagsEq : IEqualityComparer<_>) = MemoizationTable<_, _> - (compute=f, + (name, compute=f, // Only cache closed, monomorphic types (closed = all members for the type // have been processed). Generic type instantiations could be processed if we had // a decent hash function for these. @@ -803,18 +803,18 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = member _.GetHashCode((ad, nm)) = AccessorDomain.CustomGetHashCode ad + hash nm member _.Equals((ad1, nm1), (ad2, nm2)) = AccessorDomain.CustomEquals(g, ad1, ad2) && (nm1 = nm2) } - let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0 - let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0 - let recdOrClassFieldInfoCache = MakeInfoCache GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 - let ilFieldInfoCache = MakeInfoCache GetIntrinsicILFieldInfosUncached hashFlags1 - let eventInfoCache = MakeInfoCache GetIntrinsicEventInfosUncached hashFlags1 - let namedItemsCache = MakeInfoCache GetIntrinsicNamedItemsUncached hashFlags2 - let mostSpecificOverrideMethodInfoCache = MakeInfoCache GetIntrinsicMostSpecificOverrideMethodSetsUncached hashFlags0 - - let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierarchyUncached HashIdentity.Structural - let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierarchyUncached HashIdentity.Structural - let implicitConversionCache = MakeInfoCache FindImplicitConversionsUncached hashFlags3 - let isInterfaceWithStaticAbstractMethodCache = MakeInfoCache IsInterfaceTypeWithMatchingStaticAbstractMemberUncached hashFlags4 + let methodInfoCache = MakeInfoCache "methodInfoCache" GetIntrinsicMethodSetsUncached hashFlags0 + let propertyInfoCache = MakeInfoCache "propertyInfoCache" GetIntrinsicPropertySetsUncached hashFlags0 + let recdOrClassFieldInfoCache = MakeInfoCache "recdOrClassFieldInfoCache" GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 + let ilFieldInfoCache = MakeInfoCache "ilFieldInfoCache" GetIntrinsicILFieldInfosUncached hashFlags1 + let eventInfoCache = MakeInfoCache "eventInfoCache" GetIntrinsicEventInfosUncached hashFlags1 + let namedItemsCache = MakeInfoCache "namedItemsCache" GetIntrinsicNamedItemsUncached hashFlags2 + let mostSpecificOverrideMethodInfoCache = MakeInfoCache "mostSpecificOverrideMethodInfoCache" GetIntrinsicMostSpecificOverrideMethodSetsUncached hashFlags0 + + let entireTypeHierarchyCache = MakeInfoCache "entireTypeHierarchyCache" GetEntireTypeHierarchyUncached HashIdentity.Structural + let primaryTypeHierarchyCache = MakeInfoCache "primaryTypeHierarchyCache" GetPrimaryTypeHierarchyUncached HashIdentity.Structural + let implicitConversionCache = MakeInfoCache "implicitConversionCache" FindImplicitConversionsUncached hashFlags3 + let isInterfaceWithStaticAbstractMethodCache = MakeInfoCache "isInterfaceWithStaticAbstractMethodCache" IsInterfaceTypeWithMatchingStaticAbstractMemberUncached hashFlags4 // Runtime feature support diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 51c163a4608..2d047482763 100644 --- 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(options, "typeSubsumptionCache") Extras.WeakMap.getOrCreate factory @@ -51,8 +51,8 @@ let getTypeFeasibleEquivCache = 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(options, "typeFeasibleEquivCache") Extras.WeakMap.getOrCreate factory @@ -67,8 +67,8 @@ let getTypeDefinitelySubsumesNoCoerceCache = 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(options, "typeDefinitelySubsumesNoCoerceCache") Extras.WeakMap.getOrCreate factory diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 32b04b8c90f..fdca4495fda 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2334,6 +2334,7 @@ and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf // A memoization table for generating value types for big constant arrays let rawDataValueTypeGenerator = MemoizationTable( + "rawDataValueTypeGenerator", (fun (cloc, size) -> let name = CompilerGeneratedName("T" + string (newUnique ()) + "_" + string size + "Bytes") // Type names ending ...$T_37Bytes diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 5db9b2e1b29..a249c5d2bb1 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -114,6 +114,8 @@ + + @@ -147,8 +149,6 @@ - - diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index ee5a3c38670..9999b801606 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -687,7 +687,7 @@ type TcGlobals( // Build the memoization table for files let v_memoize_file = - MemoizationTable(compute, keyComparer = HashIdentity.Structural) + MemoizationTable("v_memoize_file", compute, keyComparer = HashIdentity.Structural) let v_and_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&" , None , None , [], mk_rel_sig v_bool_ty) let v_addrof_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&" , None , None , [vara], ([[varaTy]], mkByrefTy varaTy)) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 630732b4f66..f9b57d3a900 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -206,21 +206,15 @@ module CacheOptions = else EvictionMode.MailboxProcessor - let getDefault () = + let getDefault comparer = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 CacheOptions.EvictionMode = defaultEvictionMode - CacheOptions.Comparer = HashIdentity.Structural + CacheOptions.Comparer = comparer } - let getReferenceIdentity () = - { - CacheOptions.TotalCapacity = 1024 - CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = defaultEvictionMode - CacheOptions.Comparer = HashIdentity.Reference - } + let getReferenceIdentity () = getDefault HashIdentity.Reference let withNoEviction options = { options with diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi index a85aeb1d33a..809911f5116 100644 --- a/src/Compiler/Utilities/Caches.fsi +++ b/src/Compiler/Utilities/Caches.fsi @@ -46,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. diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 470d7402e07..aa83558632b 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -11,6 +11,8 @@ open System.Threading open System.Threading.Tasks open System.Runtime.CompilerServices +open FSharp.Compiler.Caches + [] type InterruptibleLazy<'T> private (value, valueFactory: unit -> 'T) = let syncObj = obj () @@ -950,10 +952,11 @@ type UniqueStampGenerator<'T when 'T: equality and 'T: not null>() = member _.Table = encodeTable.Keys /// memoize tables (all entries cached, never collected) -type MemoizationTable<'T, 'U when 'T: not null>(compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = +type MemoizationTable<'T, 'U when 'T: not null>(name, compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = - let table = new ConcurrentDictionary<'T, Lazy<'U>>(keyComparer) - let computeFunc = Func<_, _>(fun key -> lazy (compute key)) + let options = CacheOptions.getDefault keyComparer |> CacheOptions.withNoEviction + let table = new Cache<'T, Lazy<'U>>(options, name) + let computeFunc key = lazy compute key member t.Apply x = if diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index e2fba355366..b7a5d78f3a0 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -386,7 +386,7 @@ type internal UniqueStampGenerator<'T when 'T: equality and 'T: not null> = type internal MemoizationTable<'T, 'U when 'T: not null> = new: - compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> MemoizationTable<'T, 'U> + name: string * compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> MemoizationTable<'T, 'U> member Apply: x: 'T -> 'U diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs index 6ec09944926..b7aac72a93b 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerService/Caches.fs @@ -1,4 +1,4 @@ -module CompilerService.Caches +module internal CompilerService.Caches open FSharp.Compiler.Caches open Xunit @@ -14,11 +14,13 @@ let shouldNeverTimeout = 15_000 let shouldNeverTimeout = 200_000 #endif +let defaultStructural() = CacheOptions.getDefault HashIdentity.Structural + [] let ``Create and dispose many`` () = let caches = [ for _ in 1 .. 100 do - new Cache(CacheOptions.getDefault(), name = "Create and dispose many") :> IDisposable ] + new Cache(defaultStructural(), name = "Create and dispose many") :> IDisposable ] for c in caches do c.Dispose() @@ -26,7 +28,7 @@ let ``Create and dispose many`` () = [] let ``Basic add and retrieve`` () = let name = "Basic_add_and_retrieve" - use cache = new Cache(CacheOptions.getDefault(), name = name) + use cache = new Cache(defaultStructural(), name = name) use metricsListener = cache.CreateMetricsListener() cache.TryAdd("key1", 1) |> shouldBeTrue @@ -49,7 +51,7 @@ let ``Basic add and retrieve`` () = [] let ``Eviction of least recently used`` () = let name = "Eviction_of_least_recently_used" - use cache = new Cache({ CacheOptions.getDefault() with TotalCapacity = 2; HeadroomPercentage = 0 }, name = name) + use cache = new Cache({ defaultStructural() with TotalCapacity = 2; HeadroomPercentage = 0 }, name = name) use metricsListener = cache.CreateMetricsListener() cache.TryAdd("key1", 1) |> shouldBeTrue @@ -83,7 +85,7 @@ let ``Stress test evictions`` () = let iterations = 10_000 let name = "Stress test evictions" - use cache = new Cache({ CacheOptions.getDefault() with TotalCapacity = cacheSize; HeadroomPercentage = 0 }, name = name) + use cache = new Cache({ defaultStructural() with TotalCapacity = cacheSize; HeadroomPercentage = 0 }, name = name) use metricsListener = cache.CreateMetricsListener() let evictionsCompleted = new TaskCompletionSource() @@ -117,7 +119,7 @@ let ``Stress test evictions`` () = [] let ``Metrics can be retrieved`` () = - use cache = new Cache({ CacheOptions.getDefault() with TotalCapacity = 2; HeadroomPercentage = 0 }, name = "test_metrics") + use cache = new Cache({ defaultStructural() with TotalCapacity = 2; HeadroomPercentage = 0 }, name = "test_metrics") use metricsListener = cache.CreateMetricsListener() cache.TryAdd("key1", 1) |> shouldBeTrue @@ -142,7 +144,7 @@ let ``Metrics can be retrieved`` () = [] let ``GetOrAdd basic usage`` () = let cacheName = "GetOrAdd_basic_usage" - use cache = new Cache(CacheOptions.getDefault(), name = cacheName) + use cache = new Cache(defaultStructural(), name = cacheName) use metricsListener = cache.CreateMetricsListener() let mutable factoryCalls = 0 let factory k = factoryCalls <- factoryCalls + 1; String.length k @@ -164,7 +166,7 @@ let ``GetOrAdd basic usage`` () = [] let ``AddOrUpdate basic usage`` () = let cacheName = "AddOrUpdate_basic_usage" - use cache = new Cache(CacheOptions.getDefault(), name = cacheName) + use cache = new Cache(defaultStructural(), name = cacheName) use metricsListener = cache.CreateMetricsListener() cache.AddOrUpdate("x", 1) let mutable value = 0 From 2e96d7693e1810f37864ea9ed8eb6f8ca6183405 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Sun, 21 Sep 2025 21:02:25 +0200 Subject: [PATCH 27/29] fix perf --- src/Compiler/Utilities/TypeHashing.fs | 140 +++++++++++--------------- 1 file changed, 61 insertions(+), 79 deletions(-) diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index 20e57e64f42..0039960646d 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -1,6 +1,7 @@ module internal Internal.Utilities.TypeHashing open Internal.Utilities.Rational +open Internal.Utilities.Library open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.Syntax open FSharp.Compiler.TcGlobals @@ -382,7 +383,7 @@ module StructuralUtilities = [] type NeverEqual = struct - interface System.IEquatable with + interface IEquatable with member _.Equals _ = false override _.Equals _ = false @@ -398,91 +399,72 @@ module StructuralUtilities = | Nullness of nullness: NullnessInfo | TupInfo of b: bool | MeasureOne - | MeasureRational of Rational + | MeasureRational of int * int | NeverEqual of never: NeverEqual - [] - type TypeStructure = - | TypeStructure of hash: int * tokens: ImmutableArray - - static member inline FromTokens(tokens: ImmutableArray) = - // We might as well precompute the hash, because this is only going to be used as a key. - TypeStructure(hash tokens, tokens) - - override this.GetHashCode() = let (TypeStructure(h, _)) = this in h - - interface System.IEquatable with - member this.Equals that = - let (TypeStructure(h1, tokens1)) = this - let (TypeStructure(h2, tokens2)) = that - h1 = h2 && tokens1 = tokens2 - - override this.Equals that = - match that with - | :? TypeStructure as that -> (this :> IEquatable<_>).Equals that - | _ -> false - - [] - let private initialTokenCapacity = 4 + type TypeStructure = TypeStructure of ImmutableArray let inline toNullnessToken (n: Nullness) = match n.TryEvaluate() with | ValueSome k -> TypeToken.Nullness k | _ -> TypeToken.NeverEqual NeverEqual.Singleton - let rec private accumulateMeasure (tokens: ImmutableArray.Builder) (m: Measure) = - match m with - | Measure.Var mv -> tokens.Add(TypeToken.Stamp mv.Stamp) - | Measure.Const(tcref, _) -> tokens.Add(TypeToken.Stamp tcref.Stamp) - | Measure.Prod(m1, m2, _) -> - accumulateMeasure tokens m1 - accumulateMeasure tokens m2 - | Measure.Inv m1 -> accumulateMeasure tokens m1 - | Measure.One _ -> tokens.Add(TypeToken.MeasureOne) - | Measure.RationalPower(m1, r) -> - accumulateMeasure tokens m1 - tokens.Add(TypeToken.MeasureRational r) - - let rec private accumulateTType (tokens: ImmutableArray<_>.Builder ) (ty: TType) = - match ty with - | TType_ucase(u, tinst) -> - tokens.Add(TypeToken.Stamp u.TyconRef.Stamp) - tokens.Add(TypeToken.UCase u.CaseName) - - for arg in tinst do - accumulateTType tokens arg - | TType_app(tcref, tinst, n) -> - tokens.Add(TypeToken.Stamp tcref.Stamp) - tokens.Add(toNullnessToken n) - - for arg in tinst do - accumulateTType tokens arg - | TType_anon(info, tys) -> - tokens.Add(TypeToken.Stamp info.Stamp) - - for arg in tys do - accumulateTType tokens arg - | TType_tuple(tupInfo, tys) -> - tokens.Add(TypeToken.TupInfo(evalTupInfoIsStruct tupInfo)) - - for arg in tys do - accumulateTType tokens arg - | TType_forall(tps, tau) -> - for tp in tps do - tokens.Add(TypeToken.Stamp tp.Stamp) - - accumulateTType tokens tau - | TType_fun(d, r, n) -> - accumulateTType tokens d - accumulateTType tokens r - tokens.Add(toNullnessToken n) - | TType_var(r, n) -> - tokens.Add(TypeToken.Stamp r.Stamp) - tokens.Add(toNullnessToken n) - | TType_measure m -> accumulateMeasure tokens m + let rec private accumulateMeasure (m: Measure) = + seq { + match m with + | Measure.Var mv -> TypeToken.Stamp mv.Stamp + | Measure.Const(tcref, _) -> TypeToken.Stamp tcref.Stamp + | Measure.Prod(m1, m2, _) -> + yield! accumulateMeasure m1 + yield! accumulateMeasure m2 + | Measure.Inv m1 -> yield! accumulateMeasure m1 + | Measure.One _ -> TypeToken.MeasureOne + | Measure.RationalPower(m1, r) -> + yield! accumulateMeasure m1 + TypeToken.MeasureRational (GetNumerator r, GetDenominator r) + } + + let rec private accumulateTType (ty: TType) = + seq { + match ty with + | TType_ucase(u, tinst) -> + TypeToken.Stamp u.TyconRef.Stamp + TypeToken.UCase u.CaseName + + for arg in tinst do + yield! accumulateTType arg + + | TType_app(tcref, tinst, n) -> + TypeToken.Stamp tcref.Stamp + toNullnessToken n + + for arg in tinst do + yield! accumulateTType arg + | TType_anon(info, tys) -> + TypeToken.Stamp info.Stamp + + for arg in tys do + yield! accumulateTType arg + | TType_tuple(tupInfo, tys) -> + TypeToken.TupInfo(evalTupInfoIsStruct tupInfo) + + for arg in tys do + yield! accumulateTType arg + | TType_forall(tps, tau) -> + for tp in tps do + TypeToken.Stamp tp.Stamp + + yield! accumulateTType tau + | TType_fun(d, r, n) -> + yield! accumulateTType d + yield! accumulateTType r + toNullnessToken n + | TType_var(r, n) -> + TypeToken.Stamp r.Stamp + toNullnessToken n + | TType_measure m -> yield! accumulateMeasure m + } /// Get the full structure of a type as a sequence of tokens, suitable for equality - let inline getTypeStructure ty = - let tokens = ImmutableArray.CreateBuilder(initialTokenCapacity) - accumulateTType tokens ty - tokens.ToImmutable() |> TypeStructure.FromTokens + let getTypeStructure = + Extras.WeakMap.getOrCreate (fun ty -> accumulateTType ty |> ImmutableArray.ofSeq |> TypeStructure) From 314a6e41141dd7ca82f85e3524337b419a05113e Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Sun, 21 Sep 2025 21:08:42 +0200 Subject: [PATCH 28/29] format --- src/Compiler/Utilities/TypeHashing.fs | 2 +- src/Compiler/Utilities/illib.fsi | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index 0039960646d..01bc4b34cff 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -421,7 +421,7 @@ module StructuralUtilities = | Measure.One _ -> TypeToken.MeasureOne | Measure.RationalPower(m1, r) -> yield! accumulateMeasure m1 - TypeToken.MeasureRational (GetNumerator r, GetDenominator r) + TypeToken.MeasureRational(GetNumerator r, GetDenominator r) } let rec private accumulateTType (ty: TType) = diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index b7a5d78f3a0..654a7259d82 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -386,7 +386,8 @@ type internal UniqueStampGenerator<'T when 'T: equality and 'T: not null> = type internal MemoizationTable<'T, 'U when 'T: not null> = new: - name: string * compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> MemoizationTable<'T, 'U> + name: string * compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> + MemoizationTable<'T, 'U> member Apply: x: 'T -> 'U From e5ba96231b267ee44fa7eb004bc28d7a004158a4 Mon Sep 17 00:00:00 2001 From: Jakub Majocha <1760221+majocha@users.noreply.github.com> Date: Tue, 30 Sep 2025 16:37:56 +0200 Subject: [PATCH 29/29] fix merge --- .../src/FSharp.Editor/LanguageService/LanguageService.fs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 644e4a761f4..2a1e77e74a3 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -406,10 +406,6 @@ type internal FSharpPackage() as this = globalOptions.SetBackgroundAnalysisScope(openFilesOnly = not solutionAnalysis) globalOptions.BlockForCompletionItems <- false - - DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats this.DisposalToken - |> ignore - } |> CancellableTask.startAsTask cancellationToken) )