From 79863960515b0c104a42dd6833e370ce15da0d09 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Thu, 2 Jul 2026 14:46:31 +0200 Subject: [PATCH 1/2] Intern provided namespaces to fix parallel-compilation resolution race Follow-up to #19969, which interned provided *type* entities behind a lock-free CAS append + entitiesVersion design. The namespace entities on a provided type's path never got the same treatment: AddModuleOrNamespaceByMutation appended non-atomically (losing updates that race AddProvidedTypeEntity's CAS append) and the two namespace-materialization sites deduped with a non-atomic check-then-act, so two threads could each build a disjoint namespace subtree and strand the provided types interned under the orphan (spurious FS0001/FS0039). Make the namespace append atomic (shared AppendEntityByMutation CAS loop) and add GetOrInternNamespaceEntity, reusing the single providedEntitiesByMangledName intern table (one mangled name -> one entity per parent). Its factory reuses any pre-existing module/namespace of that name before creating, so a provider extending a real namespace no longer forks a duplicate. Both injection sites route through it. modulesByDemangledNameCache is now version-stamped since namespace appends can run concurrently with ModulesAndNamespacesByDemangledName reads. Fixes #20020 Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- .../.FSharp.Compiler.Service/11.0.100.md | 1 + src/Compiler/Driver/CompilerImports.fs | 65 ++++++-------- src/Compiler/TypedTree/TypedTree.fs | 88 +++++++++++-------- src/Compiler/TypedTree/TypedTree.fsi | 4 + .../ManglingNameOfProvidedTypes.fs | 77 ++++++++++++++++ 5 files changed, 161 insertions(+), 74 deletions(-) diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 992ccf70881..393275850a1 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -3,6 +3,7 @@ * Restore packaging of an F# design-time type provider that is activated via a `ProjectReference` carrying `IsFSharpDesignTimeProvider="true"`. The provider assembly is again included under `fsharp41` when packing (including `pack --no-build`); `PackageFSharpDesignTimeTools` now resolves the provider via `GetTargetPath`, which works in `dotnet pack`'s `BuildProjectReferences=false` content build without forcing an early `ResolveReferences`. ([Issue #18924](https://github.com/dotnet/fsharp/issues/18924), [PR #19979](https://github.com/dotnet/fsharp/pull/19979)) * Provided types used from multiple files no longer produce spurious FS0001 type mismatches under parallel compilation; provided-type entities are now interned so every file linking a given provided type shares one entity. ([PR #19969](https://github.com/dotnet/fsharp/pull/19969)) * TypeProviders-SDK providers now load under an unoptimized compiler; the `systemRuntimeContainsType` closure field the SDK reflects on (`tcImports`) is captured stably regardless of optimization settings. ([PR #19969](https://github.com/dotnet/fsharp/pull/19969)) +* Provided namespaces are now interned and appended atomically alongside provided types, completing the #19969 fix: under parallel compilation two files linking the same provided namespace no longer build disjoint subtrees that strand the provided types under them (spurious FS0001/FS0039). ([Issue #20020](https://github.com/dotnet/fsharp/issues/20020), [PR #20021](https://github.com/dotnet/fsharp/pull/20021)) * Fixed: Inheriting from an undefined type now reports `FS0039` exactly once instead of three times. Phase 1F and Phase 2A of inherit-clause type-checking now skip re-resolving a syntactic clause whose Phase 1D resolution already failed with `UndefinedName`, eliminating both the duplicate diagnostic and the redundant work. ([Issue #16432](https://github.com/dotnet/fsharp/issues/16432), [PR #19862](https://github.com/dotnet/fsharp/pull/19862)) * Fix several F# editor semantic-classification errors: F# delegate declarations no longer highlight the `delegate of …` syntax as a method, computation-expression builders inside list/array comprehensions are classified as `ComputationExpression`, the closing `]` of an open-ended slice (e.g. `xs[0..]`) is no longer classified as `Function`/`Method`, and `open type T` is no longer reported as unused when its imported members (static members, static fields, or DU union cases) are used. ([Issue #19905](https://github.com/dotnet/fsharp/issues/19905), [PR #19960](https://github.com/dotnet/fsharp/pull/19960)) * Diagnostic FS0027 now emits a parameter-specific message (suggesting a `let mutable x = x` shadow or `byref<_>`) instead of the illegal `let mutable x = expression` shadow when the assignment target is a function or method parameter. ([Issue #15803](https://github.com/dotnet/fsharp/issues/15803), [PR #19866](https://github.com/dotnet/fsharp/pull/19866)) diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 3c8f9bf00f8..f0868919ad0 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -1746,47 +1746,36 @@ and [] TcImports match remainingNamespace with | next :: rest -> // Inject the namespace entity - match entity.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind next with - | Some childEntity -> - tcImports.InjectProvidedNamespaceOrTypeIntoEntity( - typeProviderEnvironment, - tcConfig, - m, - childEntity, - next :: injectedNamespace, - rest, - provider, - st - ) - | None -> - // Build up the artificial namespace if there is not a real one. - let cpath = - CompPath( - ILScopeRef.Local, - SyntaxAccess.Unknown, - injectedNamespace - |> List.rev - |> List.map (fun n -> (n, ModuleOrNamespaceKind.Namespace true)) - ) - - let mid = ident (next, rangeStartup) - let mty = Construct.NewEmptyModuleOrNamespaceType(Namespace true) - - let newNamespace = - Construct.NewModuleOrNamespace (Some cpath) taccessPublic mid XmlDoc.Empty [] (MaybeLazy.Strict mty) + let childEntity = + entity.ModuleOrNamespaceType.GetOrInternNamespaceEntity( + next, + (fun () -> + // Build up the artificial namespace if there is not a real one. + let cpath = + CompPath( + ILScopeRef.Local, + SyntaxAccess.Unknown, + injectedNamespace + |> List.rev + |> List.map (fun n -> (n, ModuleOrNamespaceKind.Namespace true)) + ) - entity.ModuleOrNamespaceType.AddModuleOrNamespaceByMutation newNamespace + let mid = ident (next, rangeStartup) + let mty = Construct.NewEmptyModuleOrNamespaceType(Namespace true) - tcImports.InjectProvidedNamespaceOrTypeIntoEntity( - typeProviderEnvironment, - tcConfig, - m, - newNamespace, - next :: injectedNamespace, - rest, - provider, - st + Construct.NewModuleOrNamespace (Some cpath) taccessPublic mid XmlDoc.Empty [] (MaybeLazy.Strict mty)) ) + + tcImports.InjectProvidedNamespaceOrTypeIntoEntity( + typeProviderEnvironment, + tcConfig, + m, + childEntity, + next :: injectedNamespace, + rest, + provider, + st + ) | [] -> match st with | Some st -> diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index 3be7e711717..ab0df501ab0 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2024,7 +2024,7 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en let mutable entities = entities #if !NO_TYPEPROVIDERS - // One Entity per provided type even when linked concurrently from several files (graph-based checking). + // One Entity per provided type or namespace even when linked concurrently from several files (graph-based checking). let mutable providedEntitiesByMangledName: ConcurrentDictionary> | null = null #endif @@ -2041,12 +2041,12 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en // We should probably change to 'mutable'. // // We do not need to lock most of this mutable state since it is only ever accessed from the compiler thread. - // The exception is the four lookup tables invalidated by mutating 'entities' (provided-type linking can run - // on several graph-based-checking threads): those are read through 'cacheOptByrefByVersion' tagged with - // 'entitiesVersion', which stays coherent under concurrent appends without any lock. + // The exception is the lookup tables invalidated by mutating 'entities' (provided-type and provided-namespace + // linking can run on several graph-based-checking threads): those are read through 'cacheOptByrefByVersion' + // tagged with 'entitiesVersion', which stays coherent under concurrent appends without any lock. let activePatternElemRefCache: NameMap option ref = ref None - let mutable modulesByDemangledNameCache: NameMap option = None + let mutable modulesByDemangledNameCache: (int * NameMap) option = None let mutable exconsByDemangledNameCache: NameMap option = None @@ -2074,20 +2074,9 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en //// "FooException" --> Tycon with exception info member _.AllEntities = entities - /// Mutation used during compilation of FSharp.Core.dll - member _.AddModuleOrNamespaceByMutation(modul: ModuleOrNamespace) = - entities <- QueueList.appendOne entities modul - modulesByDemangledNameCache <- None - allEntitiesByMangledNameCache <- None - System.Threading.Interlocked.Increment(&entitiesVersion) |> ignore - -#if !NO_TYPEPROVIDERS - /// Mutation used in hosting scenarios to hold the hosted types in this module or namespace - member _.AddProvidedTypeEntity(entity: Entity) = - // Several graph-based-checking threads may link provided types into this module at once, so append - // atomically with a CAS loop. Bump 'entitiesVersion' last (release): a reader observing the new version - // is guaranteed to also see 'entity' in 'entities', so the version-stamped lookup caches recompute and - // never strand a table missing it. The caches need no explicit invalidation - the version bump does it. + /// Append 'entity', then publish 'entitiesVersion' last (release) so a reader seeing the new version also sees + /// 'entity' in 'entities' - the version-stamped lookup caches recompute rather than strand it. + member private _.AppendEntityByMutation(entity: Entity) = let rec append () = let current = entities let updated = QueueList.appendOne current entity @@ -2096,17 +2085,41 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en append () System.Threading.Interlocked.Increment(&entitiesVersion) |> ignore + /// Mutation used during compilation of FSharp.Core.dll + member mtyp.AddModuleOrNamespaceByMutation(modul: ModuleOrNamespace) = + mtyp.AppendEntityByMutation modul + +#if !NO_TYPEPROVIDERS + /// Mutation used in hosting scenarios to hold the hosted types in this module or namespace + member mtyp.AddProvidedTypeEntity(entity: Entity) = + mtyp.AppendEntityByMutation entity + + member private _.ProvidedEntityInternTable = + match providedEntitiesByMangledName with + | null -> + let created = ConcurrentDictionary>() + match System.Threading.Interlocked.CompareExchange(&providedEntitiesByMangledName, created, null) with + | null -> created + | existing -> existing + | existing -> existing + /// Interns a provided-type entity by mangled name; callers must use the returned entity. member mtyp.GetOrInternProvidedEntity(mangledName: string, create: unit -> Entity) : Entity = - let table = - match providedEntitiesByMangledName with - | null -> - let created = ConcurrentDictionary>() - match System.Threading.Interlocked.CompareExchange(&providedEntitiesByMangledName, created, null) with - | null -> created - | existing -> existing - | existing -> existing - table.GetOrAdd(mangledName, fun _ -> lazy (let entity = create () in mtyp.AddProvidedTypeEntity entity; entity)).Value + mtyp.ProvidedEntityInternTable.GetOrAdd(mangledName, fun _ -> lazy (let entity = create () in mtyp.AddProvidedTypeEntity entity; entity)).Value + + /// Interns a provided-namespace entity by mangled name, reusing any existing entity of that name; callers must use the returned entity. + member mtyp.GetOrInternNamespaceEntity(mangledName: string, create: unit -> Entity) : Entity = + mtyp.ProvidedEntityInternTable.GetOrAdd( + mangledName, + fun _ -> + lazy + match (mtyp.ModulesAndNamespacesByDemangledName: NameMap).TryFind mangledName with + | Some existing -> existing + | None -> + let entity = create () + mtyp.AddModuleOrNamespaceByMutation entity + entity) + .Value #endif /// Return a new module or namespace type with an entity added. @@ -2226,7 +2239,8 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en if entity.IsModuleOrNamespace then NameMap.add entity.DemangledModuleOrNamespaceName entity acc else acc - cacheOptByref &modulesByDemangledNameCache (fun () -> + let version = System.Threading.Volatile.Read(&entitiesVersion) + cacheOptByrefByVersion version &modulesByDemangledNameCache (fun () -> QueueList.foldBack add entities Map.empty) [] @@ -3615,13 +3629,15 @@ type NonLocalEntityRef = path[j], (fun () -> Construct.NewProvidedTycon(resolutionEnvironment, st, ccu.ImportProvidedType, false, m))) else - let cpath = entity.CompilationPath.NestedCompPath entity.LogicalName (ModuleOrNamespaceKind.Namespace false) - let newEntity = - Construct.NewModuleOrNamespace - (Some cpath) - (TAccess []) (ident(path[k], m)) XmlDoc.Empty [] - (MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType (Namespace true))) - entity.ModuleOrNamespaceType.AddModuleOrNamespaceByMutation newEntity + let newEntity = + entity.ModuleOrNamespaceType.GetOrInternNamespaceEntity( + path[k], + (fun () -> + let cpath = entity.CompilationPath.NestedCompPath entity.LogicalName (ModuleOrNamespaceKind.Namespace false) + Construct.NewModuleOrNamespace + (Some cpath) + (TAccess []) (ident(path[k], m)) XmlDoc.Empty [] + (MaybeLazy.Strict (Construct.NewEmptyModuleOrNamespaceType (Namespace true))))) injectNamespacesFromIToJ newEntity (k+1) let newEntity = injectNamespacesFromIToJ entity i diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index ca81eaab1ab..25149889328 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -1393,6 +1393,10 @@ type ModuleOrNamespaceType = /// Interns a provided-type entity by mangled name so concurrent linking from multiple files yields one /// Entity. The first caller's 'create' wins; callers must use the returned entity. member GetOrInternProvidedEntity: mangledName: string * create: (unit -> Entity) -> Entity + + /// Interns a provided-namespace entity by mangled name, reusing any existing entity of that name so concurrent + /// linking yields one Entity. Callers must use the returned entity. + member GetOrInternNamespaceEntity: mangledName: string * create: (unit -> Entity) -> Entity #endif /// Return a new module or namespace type with a value added. diff --git a/tests/FSharp.Compiler.Service.Tests/ManglingNameOfProvidedTypes.fs b/tests/FSharp.Compiler.Service.Tests/ManglingNameOfProvidedTypes.fs index 35125acd955..a1cb46dac3b 100644 --- a/tests/FSharp.Compiler.Service.Tests/ManglingNameOfProvidedTypes.fs +++ b/tests/FSharp.Compiler.Service.Tests/ManglingNameOfProvidedTypes.fs @@ -231,3 +231,80 @@ module ProvidedTypeHostingTests = let table = mtyp.AllEntitiesByCompiledAndLogicalMangledNames for name in names do Assert.True(table.ContainsKey name, $"Lookup cache dropped interned entity '{name}'.") + + let private newNamedEntity (name: string) = + Construct.NewModuleOrNamespace + (Some(CompPath(ILScopeRef.Local, SyntaxAccess.Unknown, []))) + taccessPublic + (ident (name, Range.range0)) + XmlDoc.Empty + [] + (MaybeLazy.Strict(Construct.NewEmptyModuleOrNamespaceType(Namespace true))) + + // #20020: interned provided namespaces must be unique per name, and types interned under a namespace built by racing threads stay reachable. + [] + let ``GetOrInternNamespaceEntity yields one namespace per name and keeps interned types reachable`` () = + let root = Construct.NewEmptyModuleOrNamespaceType(Namespace true) + let namespaceNames = [| "NsA"; "NsB"; "NsC" |] + let workerCount = 60 + use barrier = new System.Threading.Barrier(workerCount) + + let workers = + [ for w in 0 .. workerCount - 1 -> + let ns = namespaceNames[w % namespaceNames.Length] + let typeName = $"Type{w}" + + System.Threading.Thread(fun () -> + barrier.SignalAndWait() + let nsEntity = root.GetOrInternNamespaceEntity(ns, fun () -> newNamedEntity ns) + + nsEntity.ModuleOrNamespaceType.GetOrInternProvidedEntity(typeName, fun () -> newNamedEntity typeName) + |> ignore) ] + + workers |> List.iter (fun t -> t.Start()) + workers |> List.iter (fun t -> t.Join()) + + let namespaceEntities = root.AllEntities |> Seq.toList + Assert.Equal(namespaceNames.Length, namespaceEntities.Length) + + Assert.Equal( + namespaceNames.Length, + namespaceEntities |> List.map (fun e -> e.LogicalName) |> List.distinct |> List.length) + + for i in 0 .. namespaceNames.Length - 1 do + let ns = namespaceNames[i] + let expectedTypes = [ for w in 0 .. workerCount - 1 do if w % namespaceNames.Length = i then $"Type{w}" ] + let nsEntity = root.GetOrInternNamespaceEntity(ns, fun () -> failwith "namespace should already be interned") + let table = nsEntity.ModuleOrNamespaceType.AllEntitiesByCompiledAndLogicalMangledNames + + for typeName in expectedTypes do + Assert.True( + table.ContainsKey typeName, + $"Provided type '{typeName}' under concurrently-created namespace '{ns}' was stranded.") + + Assert.Equal(expectedTypes.Length, nsEntity.ModuleOrNamespaceType.AllEntities |> Seq.length) + + // #20020: AddModuleOrNamespaceByMutation and AddProvidedTypeEntity share the 'entities' field; concurrent appends must not drop any entity. + [] + let ``Concurrent AddModuleOrNamespaceByMutation and AddProvidedTypeEntity never lose an append`` () = + for _ in 1..5 do + let mtyp = Construct.NewEmptyModuleOrNamespaceType(Namespace true) + let appendCount = 80 + use barrier = new System.Threading.Barrier(appendCount) + + let threads = + [ for i in 0 .. appendCount - 1 -> + let entity = newNamedEntity $"E{i}" + + System.Threading.Thread(fun () -> + barrier.SignalAndWait() + + if i % 2 = 0 then + mtyp.AddModuleOrNamespaceByMutation entity + else + mtyp.AddProvidedTypeEntity entity) ] + + threads |> List.iter (fun t -> t.Start()) + threads |> List.iter (fun t -> t.Join()) + + Assert.Equal(appendCount, mtyp.AllEntities |> Seq.length) From 4cd37fb6c151fcc5dd3340a370f6f8c25d71a523 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 3 Jul 2026 10:58:15 +0200 Subject: [PATCH 2/2] Extract ConcurrentDictionary.GetOrAddLazy and reuse across intern/memo sites The provided-entity interning added for #20020 hand-rolled the ConcurrentDictionary<_, Lazy<_>> + GetOrAdd(key, fun _ -> lazy f).Value compute-once idiom that already recurs in StableNiceNameGenerator, AnonTypeGenerationTable and the FSI xmlDoc cache. Factor it into a single GetOrAddLazy extension in illib and route all four sites through it. Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/IlxGen.fs | 6 ++---- src/Compiler/Interactive/fsihelp.fs | 16 ++++++++-------- src/Compiler/TypedTree/CompilerGlobalState.fs | 6 ++---- src/Compiler/TypedTree/TypedTree.fs | 18 ++++++++---------- src/Compiler/Utilities/illib.fs | 7 +++++++ src/Compiler/Utilities/illib.fsi | 10 ++++++++++ 6 files changed, 37 insertions(+), 26 deletions(-) diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 1a5719f03b5..f38287669b7 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2445,10 +2445,8 @@ type AnonTypeGenerationTable() = let isStruct = evalAnonInfoIsStruct anonInfo let key = anonInfo.Stamp - let at = - dict.GetOrAdd(key, lazy (generateAnonType cenv mgbuf genToStringMethod (isStruct, anonInfo.ILTypeRef, anonInfo.SortedNames))) - - at.Force() |> ignore + dict.GetOrAddLazy(key, fun _ -> generateAnonType cenv mgbuf genToStringMethod (isStruct, anonInfo.ILTypeRef, anonInfo.SortedNames)) + |> ignore member this.LookupAnonType(cenv, mgbuf, genToStringMethod, anonInfo: AnonRecdTypeInfo) = match dict.TryGetValue anonInfo.Stamp with diff --git a/src/Compiler/Interactive/fsihelp.fs b/src/Compiler/Interactive/fsihelp.fs index c1629c76134..18b383894e2 100644 --- a/src/Compiler/Interactive/fsihelp.fs +++ b/src/Compiler/Interactive/fsihelp.fs @@ -14,6 +14,7 @@ module Parser = open System.Xml open System.Collections.Concurrent + open Internal.Utilities.Library type Help = { @@ -82,16 +83,15 @@ module Parser = let xmlDocCache = ConcurrentDictionary>() let tryGetXmlDocument xmlPath = - let valueFactory xmlPath = - lazy - use stream = FileSystem.OpenFileForReadShim(xmlPath) - let rawXml = stream.ReadAllText() - let xmlDocument = XmlDocument() - xmlDocument.LoadXml(rawXml) - xmlDocument + let load xmlPath = + use stream = FileSystem.OpenFileForReadShim(xmlPath) + let rawXml = stream.ReadAllText() + let xmlDocument = XmlDocument() + xmlDocument.LoadXml(rawXml) + xmlDocument try - Some(xmlDocCache.GetOrAdd(xmlPath, valueFactory).Value) + Some(xmlDocCache.GetOrAddLazy(xmlPath, load)) with _ -> None diff --git a/src/Compiler/TypedTree/CompilerGlobalState.fs b/src/Compiler/TypedTree/CompilerGlobalState.fs index 38af7ad9152..d658920787a 100644 --- a/src/Compiler/TypedTree/CompilerGlobalState.fs +++ b/src/Compiler/TypedTree/CompilerGlobalState.fs @@ -7,6 +7,7 @@ module FSharp.Compiler.CompilerGlobalState open System open System.Collections.Concurrent open System.Threading +open Internal.Utilities.Library open FSharp.Compiler.Syntax.PrettyNaming open FSharp.Compiler.Text @@ -60,10 +61,7 @@ type StableNiceNameGenerator() = member x.GetUniqueCompilerGeneratedName (name, m: range, uniq) = let basicName = GetBasicNameOfPossibleCompilerGeneratedName name let key = basicName, uniq - let lazyName = - niceNames.GetOrAdd(key, fun (basicName, _) -> - lazy innerGenerator.FreshCompilerGeneratedNameOfBasicName(basicName, m)) - lazyName.Value + niceNames.GetOrAddLazy(key, fun (basicName, _) -> innerGenerator.FreshCompilerGeneratedNameOfBasicName(basicName, m)) [] type PerFileNamingScope internal (nng: NiceNameGenerator, fileIndex: int) = diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index ab0df501ab0..1686f36aa28 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -2105,21 +2105,19 @@ type ModuleOrNamespaceType(kind: ModuleOrNamespaceKind, vals: QueueList, en /// Interns a provided-type entity by mangled name; callers must use the returned entity. member mtyp.GetOrInternProvidedEntity(mangledName: string, create: unit -> Entity) : Entity = - mtyp.ProvidedEntityInternTable.GetOrAdd(mangledName, fun _ -> lazy (let entity = create () in mtyp.AddProvidedTypeEntity entity; entity)).Value + mtyp.ProvidedEntityInternTable.GetOrAddLazy(mangledName, fun _ -> let entity = create () in mtyp.AddProvidedTypeEntity entity; entity) /// Interns a provided-namespace entity by mangled name, reusing any existing entity of that name; callers must use the returned entity. member mtyp.GetOrInternNamespaceEntity(mangledName: string, create: unit -> Entity) : Entity = - mtyp.ProvidedEntityInternTable.GetOrAdd( + mtyp.ProvidedEntityInternTable.GetOrAddLazy( mangledName, fun _ -> - lazy - match (mtyp.ModulesAndNamespacesByDemangledName: NameMap).TryFind mangledName with - | Some existing -> existing - | None -> - let entity = create () - mtyp.AddModuleOrNamespaceByMutation entity - entity) - .Value + match (mtyp.ModulesAndNamespacesByDemangledName: NameMap).TryFind mangledName with + | Some existing -> existing + | None -> + let entity = create () + mtyp.AddModuleOrNamespaceByMutation entity + entity) #endif /// Return a new module or namespace type with an entity added. diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 7236d96a1c0..fe091c640b3 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -848,6 +848,13 @@ type DictionaryExtensions() = | true, values -> values |> List.exists f | _ -> false +[] +type ConcurrentDictionaryExtensions() = + + [] + static member GetOrAddLazy(dic: ConcurrentDictionary<'key, Lazy<'value>>, key: 'key, factory: 'key -> 'value) = + dic.GetOrAdd(key, (fun k -> lazy factory k)).Value + module Lazy = let force (x: Lazy<'T>) = x.Force() diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index 654a7259d82..a200812b3bd 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -4,6 +4,7 @@ namespace Internal.Utilities.Library open System open System.Threading +open System.Collections.Concurrent open System.Collections.Generic open System.Runtime.CompilerServices @@ -297,6 +298,15 @@ type internal DictionaryExtensions = static member inline BagExistsValueForKey: dic: Dictionary<'key, 'value list> * key: 'key * f: ('value -> bool) -> bool +[] +type internal ConcurrentDictionaryExtensions = + + /// GetOrAdd whose value is produced by 'factory' at most once per key and then cached. The value is held + /// behind a Lazy, so under contention every caller observes the same instance and 'factory' runs once per key. + [] + static member GetOrAddLazy: + dic: ConcurrentDictionary<'key, Lazy<'value>> * key: 'key * factory: ('key -> 'value) -> 'value + module internal Lazy = val force: x: Lazy<'T> -> 'T