diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 9f06d74493..563f0afcbf 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -457,13 +457,11 @@ stages: _configuration: Release _testKind: testFSharpQA transparentCompiler: - FSHARP_CACHE_OVERRIDE: 256 vs_release: _configuration: Release _testKind: testVs setupVsHive: true transparentCompiler: - FSHARP_CACHE_OVERRIDE: 256 transparent_compiler_release: _configuration: Release _testKind: testCoreclr diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 1c97346384..3943455c6b 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -7,6 +7,7 @@ module internal FSharp.Compiler.TypeRelations open FSharp.Compiler.Features open Internal.Utilities.Collections open Internal.Utilities.Library +open Internal.Utilities.TypeHashing.StructuralUtilities open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.TcGlobals @@ -19,6 +20,26 @@ open Import #nowarn "3391" +[] +type CanCoerce = + | CanCoerce + | NoCoerce + +[] +type TTypeCacheKey = + | TTypeCacheKey of TypeStructure * TypeStructure * CanCoerce + static member FromStrippedTypes(ty1, ty2, canCoerce) = + TTypeCacheKey(getTypeStructure ty1, getTypeStructure ty2, canCoerce) + +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 } + new Caches.Cache(options, "typeSubsumptionCache") + Extras.WeakMap.getOrCreate factory + /// Implements a :> b without coercion based on finalized (no type variable) types // Note: This relation is approximate and not part of the language specification. // @@ -136,14 +157,8 @@ let rec TypeFeasiblySubsumesType ndeep (g: TcGlobals) (amap: ImportMap) m (ty1: List.exists (TypeFeasiblySubsumesType (ndeep + 1) g amap m ty1 NoCoerce) interfaces if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then - let key = TTypeCacheKey.FromStrippedTypes (ty1, ty2, canCoerce) - - match amap.TypeSubsumptionCache.TryGetValue(key) with - | true, subsumes -> subsumes - | false, _ -> - let subsumes = checkSubsumes ty1 ty2 - amap.TypeSubsumptionCache.TryAdd(key, subsumes) |> ignore - subsumes + let key = TTypeCacheKey.FromStrippedTypes(ty1, ty2, canCoerce) + (getTypeSubsumptionCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2) else checkSubsumes ty1 ty2 diff --git a/src/Compiler/Checking/TypeRelations.fsi b/src/Compiler/Checking/TypeRelations.fsi index 9419e617d7..b9422421ae 100644 --- a/src/Compiler/Checking/TypeRelations.fsi +++ b/src/Compiler/Checking/TypeRelations.fsi @@ -9,6 +9,11 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.Text open FSharp.Compiler.TypedTree +[] +type CanCoerce = + | CanCoerce + | NoCoerce + /// Implements a :> b without coercion based on finalized (no type variable) types val TypeDefinitelySubsumesTypeNoCoercion: ndeep: int -> g: TcGlobals -> amap: ImportMap -> m: range -> ty1: TType -> ty2: TType -> bool diff --git a/src/Compiler/Checking/import.fs b/src/Compiler/Checking/import.fs index dfcde55c46..0e9a861a37 100644 --- a/src/Compiler/Checking/import.fs +++ b/src/Compiler/Checking/import.fs @@ -50,51 +50,6 @@ type AssemblyLoader = abstract RecordGeneratedTypeRoot : ProviderGeneratedType -> unit #endif -[] -type CanCoerce = - | CanCoerce - | NoCoerce - -[] -type TTypeCacheKey = - - val ty1: TType - val ty2: TType - val canCoerce: CanCoerce - - private new (ty1, ty2, canCoerce) = - { ty1 = ty1; ty2 = ty2; canCoerce = canCoerce } - - static member FromStrippedTypes (ty1, ty2, canCoerce) = - TTypeCacheKey(ty1, ty2, canCoerce) - - interface System.IEquatable with - member this.Equals other = - if this.canCoerce <> other.canCoerce then - false - elif this.ty1 === other.ty1 && this.ty2 === other.ty2 then - true - else - HashStamps.stampEquals this.ty1 other.ty1 - && HashStamps.stampEquals this.ty2 other.ty2 - - override this.Equals(other:objnull) = - match other with - | :? TTypeCacheKey as p -> (this :> System.IEquatable).Equals p - | _ -> false - - override this.GetHashCode () : int = - HashStamps.hashTType this.ty1 - |> pipeToHash (HashStamps.hashTType this.ty2) - |> pipeToHash (hash this.canCoerce) - - override this.ToString () = $"{this.ty1.DebugText}-{this.ty2.DebugText}" - -let typeSubsumptionCache = - // Leave most of the capacity in reserve for bursts. - let options = { CacheOptions.getDefault() with TotalCapacity = 131072; HeadroomPercentage = 75 } - lazy new Cache(options, "typeSubsumptionCache") - //------------------------------------------------------------------------- // Import an IL types as F# types. //------------------------------------------------------------------------- @@ -117,8 +72,6 @@ type ImportMap(g: TcGlobals, assemblyLoader: AssemblyLoader) = member _.ILTypeRefToTyconRefCache = typeRefToTyconRefCache - member val TypeSubsumptionCache: Cache = typeSubsumptionCache.Value - let CanImportILScopeRef (env: ImportMap) m scoref = let isResolved assemblyRef = diff --git a/src/Compiler/Checking/import.fsi b/src/Compiler/Checking/import.fsi index 72611e12bf..c0ee183f2e 100644 --- a/src/Compiler/Checking/import.fsi +++ b/src/Compiler/Checking/import.fsi @@ -36,24 +36,6 @@ type AssemblyLoader = abstract RecordGeneratedTypeRoot: ProviderGeneratedType -> unit #endif -[] -type CanCoerce = - | CanCoerce - | NoCoerce - -[] -type TTypeCacheKey = - interface System.IEquatable - private new: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey - - static member FromStrippedTypes: ty1: TType * ty2: TType * canCoerce: CanCoerce -> TTypeCacheKey - - val ty1: TType - val ty2: TType - val canCoerce: CanCoerce - - override GetHashCode: unit -> int - /// Represents a context used for converting AbstractIL .NET and provided types to F# internal compiler data structures. /// Also cache the conversion of AbstractIL ILTypeRef nodes, based on hashes of these. /// @@ -70,9 +52,6 @@ type ImportMap = /// The TcGlobals for the import context member g: TcGlobals - /// Type subsumption cache - member TypeSubsumptionCache: Cache - module Nullness = [] diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index aa23d1534a..7c3422bd96 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -538,7 +538,7 @@ type internal TypeCheckInfo // check that type of value is the same or subtype of tcref // yes - allow access to protected members // no - strip ability to access protected members - if TypeRelations.TypeFeasiblySubsumesType 0 g amap m thisTy Import.CanCoerce ty then + if TypeRelations.TypeFeasiblySubsumesType 0 g amap m thisTy TypeRelations.CanCoerce ty then ad else AccessibleFrom(paths, None) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 1220283da1..37f93dc298 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -118,21 +118,6 @@ module CacheOptions = CacheOptions.EvictionMode = EvictionMode.NoEviction } -module Cache = - // During testing a lot of compilations are started in app domains and subprocesses. - // This is a reliable way to pass the override to all of them. - [] - let private overrideVariable = "FSHARP_CACHE_OVERRIDE" - - /// Use for testing purposes to reduce memory consumption in testhost and its subprocesses. - let OverrideCapacityForTesting () = - Environment.SetEnvironmentVariable(overrideVariable, "4096", EnvironmentVariableTarget.Process) - - let applyOverride (options: CacheOptions<_>) = - match Int32.TryParse(Environment.GetEnvironmentVariable(overrideVariable)) with - | true, n when options.TotalCapacity > n -> { options with TotalCapacity = n } - | _ -> options - // It is important that this is not a struct, because LinkedListNode holds a reference to it, // and it holds the reference to that Node, in a circular way. [] @@ -176,8 +161,6 @@ type Cache<'Key, 'Value when 'Key: not null> internal (options: CacheOptions<'Ke if options.HeadroomPercentage < 0 then invalidArg "HeadroomPercentage" "HeadroomPercentage must be positive" - let options = Cache.applyOverride options - let name = defaultArg name (Guid.NewGuid().ToString()) // Determine evictable headroom as the percentage of total capcity, since we want to not resize the dictionary. diff --git a/src/Compiler/Utilities/Caches.fsi b/src/Compiler/Utilities/Caches.fsi index 62f9820cf7..9ecdcd2a79 100644 --- a/src/Compiler/Utilities/Caches.fsi +++ b/src/Compiler/Utilities/Caches.fsi @@ -49,10 +49,6 @@ module internal CacheOptions = /// Set eviction mode to NoEviction. val withNoEviction: CacheOptions<'Key> -> CacheOptions<'Key> -module internal Cache = - /// Use for testing purposes to reduce memory consumption in testhost and its subprocesses. - val OverrideCapacityForTesting: unit -> unit - [] type internal Cache<'Key, 'Value when 'Key: not null> = new: options: CacheOptions<'Key> * ?name: string -> Cache<'Key, 'Value> diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index c085bc84ff..0f7d4740bb 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -8,6 +8,7 @@ open FSharp.Compiler.Text open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps +open System.Collections.Immutable type ObserverVisibility = | PublicOnly @@ -357,68 +358,111 @@ module HashTastMemberOrVals = hashNonMemberVal (g, obs) (tps, vref.Deref, tau, cxs) | Some _ -> hashMember (g, obs) emptyTyparInst vref.Deref -/// Practical TType comparer strictly for the use with cache keys. -module HashStamps = - let rec typeInstStampsEqual (tys1: TypeInst) (tys2: TypeInst) = - tys1.Length = tys2.Length && (tys1, tys2) ||> Seq.forall2 stampEquals - - and inline typarStampEquals (t1: Typar) (t2: Typar) = t1.Stamp = t2.Stamp - - and typarsStampsEqual (tps1: Typars) (tps2: Typars) = - tps1.Length = tps2.Length && (tps1, tps2) ||> Seq.forall2 typarStampEquals - - and measureStampEquals (m1: Measure) (m2: Measure) = - match m1, m2 with - | Measure.Var(mv1), Measure.Var(mv2) -> mv1.Stamp = mv2.Stamp - | Measure.Const(t1, _), Measure.Const(t2, _) -> t1.Stamp = t2.Stamp - | Measure.Prod(m1, m2, _), Measure.Prod(m3, m4, _) -> measureStampEquals m1 m3 && measureStampEquals m2 m4 - | Measure.Inv m1, Measure.Inv m2 -> measureStampEquals m1 m2 - | Measure.One _, Measure.One _ -> true - | Measure.RationalPower(m1, r1), Measure.RationalPower(m2, r2) -> r1 = r2 && measureStampEquals m1 m2 - | _ -> false - - and nullnessEquals (n1: Nullness) (n2: Nullness) = - match n1, n2 with - | Nullness.Known k1, Nullness.Known k2 -> k1 = k2 - | Nullness.Variable _, Nullness.Variable _ -> true - | _ -> false - - and stampEquals ty1 ty2 = - match ty1, ty2 with - | TType_ucase(u, tys1), TType_ucase(v, tys2) -> u.CaseName = v.CaseName && typeInstStampsEqual tys1 tys2 - | TType_app(tcref1, tinst1, n1), TType_app(tcref2, tinst2, n2) -> - tcref1.Stamp = tcref2.Stamp - && nullnessEquals n1 n2 - && typeInstStampsEqual tinst1 tinst2 - | TType_anon(info1, tys1), TType_anon(info2, tys2) -> info1.Stamp = info2.Stamp && typeInstStampsEqual tys1 tys2 - | TType_tuple(c1, tys1), TType_tuple(c2, tys2) -> c1 = c2 && typeInstStampsEqual tys1 tys2 - | TType_forall(tps1, tau1), TType_forall(tps2, tau2) -> stampEquals tau1 tau2 && typarsStampsEqual tps1 tps2 - | TType_var(r1, n1), TType_var(r2, n2) -> r1.Stamp = r2.Stamp && nullnessEquals n1 n2 - | TType_measure m1, TType_measure m2 -> measureStampEquals m1 m2 - | _ -> false - - let inline hashStamp (x: Stamp) : Hash = uint x * 2654435761u |> int - - // The idea is to keep the illusion of immutability of TType. - // This hash must be stable during compilation, otherwise we won't be able to find keys or evict from the cache. - let rec hashTType ty : Hash = +/// +/// StructuralUtilities: produce a conservative structural fingerprint of TType. +/// +/// Current (sole) usage: +/// Key in the typeSubsumptionCache. The key must never give a false positive +/// (two non-subsuming types producing identical token sequences). False negatives +/// are acceptable and simply reduce cache hit rate. +/// +/// Properties: +/// * Uses per-compilation stamps (entities, typars, anon records, measures). +/// * Emits shape for union cases (declaring type stamp + case name), tuple structness, +/// function arrows, forall binders, nullness, measures, generic arguments. +/// * Unknown/variable nullness => NeverEqual token to force inequality (avoid unsound hits). +/// +/// Non-goals: +/// * Cross-compilation stability. +/// * Perfect canonicalisation or alpha-equivalence collapsing. +/// +/// +module StructuralUtilities = + [] + type NeverEqual = + struct + interface System.IEquatable with + member _.Equals _ = false + + override _.Equals _ = false + override _.GetHashCode() = 0 + end + + static member Singleton = NeverEqual() + + [] + type TypeToken = + | Stamp of stamp: Stamp + | UCase of name: string + | Nullness of nullness: NullnessInfo + | TupInfo of b: bool + | MeasureOne + | MeasureRational of rational: Rational + | NeverEqual of never: NeverEqual + + type TypeStructure = TypeToken[] + + [] + let private initialTokenCapacity = 4 + + let inline toNullnessToken (n: Nullness) = + match n.TryEvaluate() with + | ValueSome k -> TypeToken.Nullness k + | _ -> TypeToken.NeverEqual NeverEqual.Singleton + + let rec private accumulateMeasure (tokens: ResizeArray) (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: ResizeArray) (ty: TType) = match ty with - | TType_ucase(u, tinst) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hash u.CaseName) - | TType_app(tcref, tinst, Nullness.Known n) -> - tinst - |> hashListOrderMatters (hashTType) - |> pipeToHash (hashStamp tcref.Stamp) - |> pipeToHash (hash n) - | TType_app(tcref, tinst, Nullness.Variable _) -> tinst |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp tcref.Stamp) - | TType_anon(info, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hashStamp info.Stamp) - | TType_tuple(c, tys) -> tys |> hashListOrderMatters (hashTType) |> pipeToHash (hash c) + | TType_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) -> - tps - |> Seq.map _.Stamp - |> hashListOrderMatters (hashStamp) - |> pipeToHash (hashTType tau) - | TType_fun(d, r, Nullness.Known n) -> hashTType d |> pipeToHash (hashTType r) |> pipeToHash (hash n) - | TType_fun(d, r, Nullness.Variable _) -> hashTType d |> pipeToHash (hashTType r) - | TType_var(r, Nullness.Known n) -> hashStamp r.Stamp |> pipeToHash (hash n) - | TType_var(r, Nullness.Variable _) -> hashStamp r.Stamp - | TType_measure _ -> 0 + 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 + + /// Get the full structure of a type as a sequence of tokens, suitable for equality + let getTypeStructure ty = + let tokens = ResizeArray(initialTokenCapacity) + accumulateTType tokens ty + tokens.ToArray() diff --git a/src/Compiler/Utilities/lib.fs b/src/Compiler/Utilities/lib.fs index e3b08d3c98..540ea8c452 100755 --- a/src/Compiler/Utilities/lib.fs +++ b/src/Compiler/Utilities/lib.fs @@ -9,6 +9,7 @@ open System.Text open System.Threading.Tasks open Internal.Utilities.Collections open Internal.Utilities.Library +open System.Runtime.CompilerServices let debug = false @@ -458,3 +459,17 @@ module Async = let! a = a return f a } + +module WeakMap = + /// Provides association of lazily-created values with arbitrary key objects. + /// The associated value is created on first request and kept alive only while the key + /// is strongly referenced elsewhere (backed by ConditionalWeakTable). + /// + /// Usage: + /// let getValueFor = WeakMap.getOrCreate (fun key -> expensiveInit key) + /// let v = getValueFor someKey + let getOrCreate valueFactory = + let table = ConditionalWeakTable<_, _>() + // Cached factory to avoid allocating a new lambda per lookup. + let factory = ConditionalWeakTable.CreateValueCallback(fun k -> valueFactory k) + fun (key: 'Key when 'Key: not null) -> table.GetValue(key, factory) diff --git a/src/Compiler/Utilities/lib.fsi b/src/Compiler/Utilities/lib.fsi index 566d677914..fcf977683d 100644 --- a/src/Compiler/Utilities/lib.fsi +++ b/src/Compiler/Utilities/lib.fsi @@ -295,3 +295,15 @@ module ListParallel = [] module Async = val map: ('T -> 'U) -> Async<'T> -> Async<'U> + +module internal WeakMap = + /// Provides association of lazily-created values with arbitrary key objects. + /// The associated value is created on first request and kept alive only while the key + /// is strongly referenced elsewhere (backed by ConditionalWeakTable). + /// + /// Usage: + /// let getValueFor = WeakMap.getOrCreate (fun key -> expensiveInit key) + /// let v = getValueFor someKey + val internal getOrCreate: + valueFactory: ('Key -> 'Value) -> ('Key -> 'Value) + when 'Key: not struct and 'Key: not null and 'Value: not struct diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 70308361fd..1823c5a1b6 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -202,8 +202,6 @@ module OneTimeSetup = log "Adding AssemblyResolver" AssemblyResolver.addResolver () #endif - log "Overriding cache capacity" - Cache.OverrideCapacityForTesting() log "Installing TestConsole redirection" TestConsole.install() diff --git a/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj b/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj index 30a871ad28..96fde123dc 100644 --- a/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj +++ b/vsintegration/tests/UnitTests/VisualFSharp.UnitTests.fsproj @@ -17,6 +17,9 @@ + + XunitSetup.fs + @@ -79,6 +82,7 @@ +