From cf7b36ef8c00ffda22ea8768940246eea3bad209 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Tue, 1 Sep 2026 16:53:54 +0200 Subject: [PATCH 1/3] Import: share a referenced project's CCU instead of pickling it A project reference pickles its signature once and every consumer unpickles its own copy: five projects referencing one hub hold five copies of its signature TAST. The pickled tree is already in the shape consumers need, so offer it directly through IImportedProjectCcu, and pickle only when something asks. Four things make it usable: - Remapped against a ccu made for this view, not the project's live one, which a consumer would else hold whole. - PruneExportedSignatureInPlace brings it to the shape unpickling produces: no value definitions, no display-only data, no compiled-representation cache. - Every non-local reference is re-pointed at the reading project's ccu of the same name, as unpickling does; a name the reader lacks keeps ours. So a consumer on another framework takes it too. - What each name bound to is recorded, and a second consumer takes that copy only where it resolves all of them alike. Binding runs once the batch is registered and before anything relinks: an assembly unpickled beside it resolves the names it mentions against what is registered, and a delayed CCU is an error there. Depends on sharing imported assemblies (#20296). Also fixes a check-then-act race in BackgroundCompiler: builders were cached without a second look under the gate, so callers arriving together each built the project. Retained memory, under editor options. Diagnostics identical with the change off and on: Fantomas 8 proj 350.2 -> 275.7 MB -74.5 (-21.3%) ReSharper.FSharp 10 proj 384.9 -> 304.6 MB -80.3 (-20.9%) FsToolkit 8 proj 87.7 -> 70.1 MB -17.6 (-20.1%) Oxpecker 16 proj 131.7 -> 114.2 MB -17.5 (-13.3%) Prime 5 proj 112.2 -> 97.9 MB -14.3 (-12.7%) IcedTasks 7 proj 97.0 -> 92.4 MB -4.6 (-4.7%) FCS solution 14 proj 820.8 -> 818.7 MB -2.1 (-0.2%) consoleapp 1 proj 29.4 -> 29.4 MB 0.0 The FCS solution gains least: nearly every edge in it crosses framework import layers, so each consumer rebuilds a copy of its own. Co-Authored-By: Claude Opus 5 --- src/Compiler/Driver/CompilerConfig.fs | 11 +- src/Compiler/Driver/CompilerConfig.fsi | 7 +- src/Compiler/Driver/CompilerImports.fs | 298 ++++++-- src/Compiler/Driver/CompilerImports.fsi | 15 + src/Compiler/Service/BackgroundCompiler.fs | 29 +- src/Compiler/Service/IncrementalBuild.fs | 184 ++++- src/Compiler/Service/IncrementalBuild.fsi | 4 +- src/Compiler/Service/TransparentCompiler.fs | 27 +- src/Compiler/TypedTree/TcGlobals.fs | 27 + src/Compiler/TypedTree/TcGlobals.fsi | 4 + src/Compiler/TypedTree/TypedTreeOps.Remap.fs | 70 +- src/Compiler/TypedTree/TypedTreeOps.Remap.fsi | 6 +- .../TypedTree/TypedTreeOps.Remapping.fs | 121 ++-- .../TypedTree/TypedTreeOps.Remapping.fsi | 13 + .../TypedTree/TypedTreeOps.Transforms.fs | 40 ++ .../TypedTree/TypedTreeOps.Transforms.fsi | 9 + .../FSharp.Compiler.Service.Tests.fsproj | 1 + .../ProjectReferenceHandoverTests.fs | 657 ++++++++++++++++++ 18 files changed, 1314 insertions(+), 209 deletions(-) create mode 100644 tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 00d1a9acb2f..1fae35005ee 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -446,11 +446,7 @@ type TypeCheckingConfig = } [] -type ImportReuseKey = - { - LangVersion: decimal - CheckNullness: bool - } +type ImportReuseKey = { ImportsNullness: bool } [] type TcConfigBuilder = @@ -1413,8 +1409,9 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.importReuseKey = { - ImportReuseKey.LangVersion = data.langVersion.SpecifiedVersion - ImportReuseKey.CheckNullness = data.checkNullness + ImportReuseKey.ImportsNullness = + data.checkNullness + && data.langVersion.SupportsFeature LanguageFeature.NullnessChecking } member _.dumpSignatureData = data.dumpSignatureData diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index 5ed1050561c..7b702da71d8 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -225,11 +225,10 @@ type TypeCheckingConfig = DumpGraph: bool } -/// A field belongs here when two projects differing in it cannot reuse one imported form +/// What two projects must agree on before one can reuse the other's imports. Importing consults the +/// settings in one place only, whether nullable-reference attributes are read into the TAST. [] -type ImportReuseKey = - { LangVersion: decimal - CheckNullness: bool } +type ImportReuseKey = { ImportsNullness: bool } [] type TcConfigBuilder = diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index e311c56c110..9ae74ee18b1 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -438,11 +438,12 @@ module internal SharedImportedCcus = /// ILAssemblyRef cannot serve: it does not separate one package's builds for different frameworks [] type AssemblyFileId = - | AssemblyFileId of text: string + | AssemblyFileId of path: string * stamp: int64 option member this.Text = match this with - | AssemblyFileId text -> text + | AssemblyFileId(path, Some stamp) -> path + "|" + string stamp + | AssemblyFileId(path, None) -> path + "|nostamp" type AssemblyKeyInfo = { @@ -468,7 +469,7 @@ module internal SharedImportedCcus = /// Weak: an entry is held by the projects using it, and holds the rest of its own closure let private cache = ConcurrentDictionary>() - let private nameComparer = StringComparer.OrdinalIgnoreCase + let nameComparer = StringComparer.OrdinalIgnoreCase /// What a shared ccu may close over besides its own closure. Functions because TcImports comes later. type FrameworkLayer = @@ -523,10 +524,12 @@ module internal SharedImportedCcus = Context: SharedImportContext } - type ShareableAssembly = + /// The key a ccu is published under, and the names it references - held strongly, which is what lets + /// the cache be weak + type SharedCcuClosure = { Key: SharedCcuKey - Closure: SimpleAssemblyName list + ReferencedNames: SimpleAssemblyName list } /// Names walked to inside the batch, then those leaving it - framework assemblies the stamp pins @@ -548,7 +551,7 @@ module internal SharedImportedCcus = /// No key where the closure is not shareable: entities and their per-CCU caches would point into one /// project's copy of an unshared assembly. let computeKeys (frameworkStamp: int64) (assemblies: Dictionary) isShareable = - let keys = Dictionary(nameComparer) + let keys = Dictionary(nameComparer) for KeyValue(name, assembly) in assemblies do let inside, outside = closureOf assemblies name @@ -568,7 +571,7 @@ module internal SharedImportedCcus = FrameworkStamp = frameworkStamp CcuName = None } - Closure = assembly.References + ReferencedNames = assembly.References } keys @@ -583,6 +586,9 @@ module internal SharedImportedCcus = None | _ -> None + /// A racer builds its own rather than wait: claims can be taken in opposite orders. + let private claims = ConcurrentDictionary() + /// `build` is not called on a hit, which is what lets the F# path skip unpickling entirely let getOrBuild (entry: SharedImport option) (build: unit -> CcuThunk) = match entry with @@ -591,15 +597,58 @@ module internal SharedImportedCcus = match tryGet entry.Key with | Some ccu -> ccu | None -> - let ccu = build () - entry.Context.HoldForPublication(entry.Key, ccu) - ccu + let claim = obj () + let owner = claims.GetOrAdd(entry.Key, claim) + let mine = obj.ReferenceEquals(owner, claim) + + // Winning the claim can mean the previous holder published between the miss above and here + match (if mine then tryGet entry.Key else None) with + | Some ccu -> + claims.TryRemove entry.Key |> ignore + ccu + | None -> + + let ccu = + try + build () + with _ -> + if mine then + claims.TryRemove entry.Key |> ignore + + reraise () + + if mine then + entry.Context.HoldForPublication(entry.Key, ccu) + + ccu - /// Last writer wins: two projects importing at once each keep the ccu they built, both consistent let add (key: SharedCcuKey) (ccu: CcuThunk) = - cache[key] <- WeakReference ccu + let fresh = WeakReference ccu + + cache.AddOrUpdate( + key, + fresh, + fun _ existing -> + match existing.TryGetTarget() with + | true, _ -> existing + | _ -> fresh + ) + |> ignore - let clear () = cache.Clear() + claims.TryRemove key |> ignore + + let clear () = + cache.Clear() + claims.Clear() + +type IImportedProjectCcu = + abstract Stamp: int64 + + abstract ReferencedCcuNames: string list + + abstract CanBeTaken: bool + + abstract GetCcu: callerTcGlobals: TcGlobals * resolve: (string -> CcuThunk option) -> CcuThunk type ImportedBinary = { @@ -627,6 +676,19 @@ type ImportedAssembly = FSharpOptimizationData: InterruptibleLazy } +let mkImportedAssembly (data: IRawFSharpAssemblyData) ilScopeRef ccu optimizationData = + { + FSharpViewOfMetadata = ccu + AssemblyAutoOpenAttributes = data.GetAutoOpenAttributes() + AssemblyInternalsVisibleToAttributes = data.GetInternalsVisibleToAttributes() + FSharpOptimizationData = optimizationData +#if !NO_TYPEPROVIDERS + IsProviderGenerated = false + TypeProviders = [] +#endif + ILScopeRef = ilScopeRef + } + type AvailableImportedAssembly = | ResolvedImportedAssembly of ImportedAssembly * range | UnresolvedImportedAssembly of string * range @@ -2313,6 +2375,26 @@ and [] TcImports phase2 + member tcImports.TryImportProjectCcu + (m, assemblyData: IRawFSharpAssemblyData, ilScopeRef, willTake, takenCcus: ResizeArray) + = + match assemblyData with + | :? IImportedProjectCcu as projectCcu -> + if willTake then + // The reader's ccus are not registered yet, so this is filled once the batch is + let delayed = CcuThunk.CreateDelayed assemblyData.ShortAssemblyName + takenCcus.Add(projectCcu, delayed) + + let ccuinfo = mkImportedAssembly assemblyData ilScopeRef delayed (notlazy None) + + tcImports.RegisterCcu ccuinfo + + // Nothing to relink: built against the ccus this project has + Some(fun () -> [ ResolvedImportedAssembly(ccuinfo, m) ]) + else + None + | _ -> None + member tcImports.PrepareToImportReferencedFSharpAssembly (ctok, m, fileName, dllinfo: ImportedBinary, ?shared: SharedImportedCcus.SharedImport) = @@ -2425,18 +2507,7 @@ and [] TcImports Some(fixupThunk ())) - let ccuinfo = - { - FSharpViewOfMetadata = ccu - AssemblyAutoOpenAttributes = ilModule.GetAutoOpenAttributes() - AssemblyInternalsVisibleToAttributes = ilModule.GetInternalsVisibleToAttributes() - FSharpOptimizationData = optdata -#if !NO_TYPEPROVIDERS - IsProviderGenerated = false - TypeProviders = [] -#endif - ILScopeRef = ilScopeRef - } + let ccuinfo = mkImportedAssembly ilModule ilScopeRef ccu optdata let phase2 () = #if !NO_TYPEPROVIDERS @@ -2536,6 +2607,23 @@ and [] TcImports return None } + let shortName (r: AssemblyResolution) = + Path.GetFileNameWithoutExtension r.resolvedPath + + let tryGetSharedCcuClosure (keys: Dictionary<_, SharedImportedCcus.SharedCcuClosure> option) r = + keys + |> Option.bind (fun keys -> + match keys.TryGetValue(shortName r) with + | true, closure -> Some closure + | _ -> None) + + /// Two resolutions claiming one name would key whichever was seen last, so neither is shared + let ambiguousNames all = + all + |> List.countBy (fun (r, _) -> shortName r) + |> List.choose (fun (name, n) -> if n > 1 then Some name else None) + |> fun names -> HashSet<_>(names, SharedImportedCcus.nameComparer) + /// Also reports a multi-module assembly, whose auxiliary modules need the importing project let reachableAssemblyNames self (data: IRawFSharpAssemblyData) = let names = ResizeArray() @@ -2568,54 +2656,55 @@ and [] TcImports | None -> false #endif - let fileIdentity (r: AssemblyResolution) : SharedImportedCcus.AssemblyFileId = - let writeStamp = - try - string (FileSystem.GetLastWriteTimeShim r.resolvedPath).Ticks - with _ -> - "nostamp" + let fileIdentity (r: AssemblyResolution) (data: IRawFSharpAssemblyData) = + let stamp = + match data with + | :? IImportedProjectCcu as projectCcu -> Some projectCcu.Stamp + | _ -> + try + Some (FileSystem.GetLastWriteTimeShim r.resolvedPath).Ticks + with _ -> + None - SharedImportedCcus.AssemblyFileId(r.resolvedPath + "|" + writeStamp) + SharedImportedCcus.AssemblyFileId(r.resolvedPath, stamp) - let sharedKeys (all: (AssemblyResolution * IRawFSharpAssemblyData) list) = + /// A referenced project may be pinned by a key only where this project takes its contents. + let sharedKeys (all: (AssemblyResolution * IRawFSharpAssemblyData) list) takenFromProject = let ic = StringComparer.OrdinalIgnoreCase - let short (p: string) = Path.GetFileNameWithoutExtension p let frameworkStamp = match importsBase with | Some b -> b.Stamp | None -> 0L - // Two resolutions claiming one name would key whichever was seen last, so neither is shared - let ambiguous = - all - |> List.countBy (fun (r, _) -> short r.resolvedPath) - |> List.choose (fun (name, n) -> if n > 1 then Some name else None) - |> fun names -> HashSet<_>(names, ic) + let ambiguous = ambiguousNames all let assemblies = Dictionary(ic) - let shareable = HashSet<_>(ic) + // phase2 mutates a type provider's contents. A project reference joins only when taken + let shareableNames = HashSet<_>(ic) for r, data in all do - let name = short r.resolvedPath + let name = shortName r let refs, isMultiModule = reachableAssemblyNames name data assemblies[name] <- { - File = fileIdentity r + File = fileIdentity r data References = refs } - // A project's own output changes every build; phase2 mutates a type provider's contents if - r.ProjectReference.IsNone - && not isMultiModule + not isMultiModule && not (ambiguous.Contains name) && not (isTypeProviderAssembly data) then - shareable.Add name |> ignore + match data with + | :? IImportedProjectCcu when takenFromProject name -> shareableNames.Add name |> ignore + | :? IImportedProjectCcu -> () + | _ when r.ProjectReference.IsNone -> shareableNames.Add name |> ignore + | _ -> () // A reference must resolve to what the key pins - this batch or the framework layer - or to // nothing anywhere. One only an earlier batch resolves would be keyed as unresolved. @@ -2640,16 +2729,20 @@ and [] TcImports pinnedByKey[ref] <- v v - for name in List.ofSeq shareable do + for name in List.ofSeq shareableNames do if not (assemblies[name].References |> List.forall isPinnedByKey) then - shareable.Remove name |> ignore + shareableNames.Remove name |> ignore - SharedImportedCcus.computeKeys frameworkStamp assemblies shareable.Contains + SharedImportedCcus.computeKeys frameworkStamp assemblies shareableNames.Contains let contexts = ResizeArray() + /// The project ccus taken, each with the delayed thunk the bind below fills in. + let takenCcus = ResizeArray() + let registerDll - (keys: Dictionary option) + (keys: Dictionary option) + (taken: HashSet) (r: AssemblyResolution, assemblyData: IRawFSharpAssemblyData) = let m = r.originalReference.Range @@ -2659,18 +2752,16 @@ and [] TcImports // A project's own output can share a simple name with a package, so it is excluded here let shared = - match keys with - | Some keys when r.ProjectReference.IsNone -> - match keys.TryGetValue(Path.GetFileNameWithoutExtension fileName) with - | true, shareable -> - let ctx = SharedImportedCcus.SharedImportContext(frameworkLayer, shareable.Closure) + match tryGetSharedCcuClosure keys r with + | Some closure when r.ProjectReference.IsNone -> + let ctx = + SharedImportedCcus.SharedImportContext(frameworkLayer, closure.ReferencedNames) - contexts.Add ctx + contexts.Add ctx - let import: SharedImportedCcus.SharedImport = { Key = shareable.Key; Context = ctx } + let import: SharedImportedCcus.SharedImport = { Key = closure.Key; Context = ctx } - Some import - | _ -> None + Some import | _ -> None if tcImports.IsAlreadyRegistered ilShortAssemName then @@ -2696,17 +2787,20 @@ and [] TcImports tcImports.RegisterDll dllinfo let phase2 = - if assemblyData.HasAnyFSharpSignatureDataAttribute then - if not assemblyData.HasMatchingFSharpSignatureDataAttribute then - errorR (Error(FSComp.SR.buildDifferentVersionMustRecompile fileName, m)) - tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo, ?shared = shared) + match tcImports.TryImportProjectCcu(m, assemblyData, ilScopeRef, taken.Contains(shortName r), takenCcus) with + | Some phase2 -> phase2 + | None -> + if assemblyData.HasAnyFSharpSignatureDataAttribute then + if not assemblyData.HasMatchingFSharpSignatureDataAttribute then + errorR (Error(FSComp.SR.buildDifferentVersionMustRecompile fileName, m)) + tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo, ?shared = shared) + else + try + tcImports.PrepareToImportReferencedFSharpAssembly(ctok, m, fileName, dllinfo, ?shared = shared) + with e -> + error (Error(FSComp.SR.buildErrorOpeningBinaryFile (fileName, e.Message), m)) else - try - tcImports.PrepareToImportReferencedFSharpAssembly(ctok, m, fileName, dllinfo, ?shared = shared) - with e -> - error (Error(FSComp.SR.buildErrorOpeningBinaryFile (fileName, e.Message), m)) - else - tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo, ?shared = shared) + tcImports.PrepareToImportReferencedILAssembly(ctok, m, fileName, dllinfo, ?shared = shared) async { return phase2 () } @@ -2738,11 +2832,69 @@ and [] TcImports && tcConfig.reduceMemoryUsage = ReduceMemoryFlag.Yes && importsBase.Value.GetImportReuseKey ctok = tcConfig.importReuseKey then - Some(sharedKeys resolved) + // The keys come after: admitting these lets assemblies referencing them be keyed + let taken = HashSet(SharedImportedCcus.nameComparer) + + for r, data in resolved do + match data with + | :? IImportedProjectCcu as projectCcu when projectCcu.CanBeTaken -> taken.Add(shortName r) |> ignore + | _ -> () + + Some(sharedKeys resolved taken.Contains), taken else - None + None, HashSet(SharedImportedCcus.nameComparer) + + let keys, taken = keys + let phase2s = resolved |> List.map (registerDll keys taken) + + // Before anything relinks: an assembly unpickled here, or an orphan from an earlier batch, + // resolves the names it mentions against what is registered, and a delayed one errors there + if takenCcus.Count > 0 then + // The tree, not the reader's own thunk: that wrapper is unique to it + let boundCcus = Dictionary(SharedImportedCcus.nameComparer) + + let resolve name = + match boundCcus.TryGetValue name with + | true, ccu -> Some ccu + | _ -> + match tcImports.FindCcu(ctok, range0, name, lookupOnly = true) with + | ResolvedCcu ccu -> Some ccu + | UnresolvedCcu _ -> None + + // A ccu is bound after the ones it names + let ordered = ResizeArray() + let placed = HashSet(SharedImportedCcus.nameComparer) + let visiting = HashSet(SharedImportedCcus.nameComparer) + + let byName = + Dictionary(SharedImportedCcus.nameComparer) + + for projectCcu, delayed in takenCcus do + byName[delayed.AssemblyName] <- (projectCcu, delayed) + + let rec place (name: string) = + if not (placed.Contains name) && visiting.Add name then + match byName.TryGetValue name with + | true, ((projectCcu, _) as entry) -> + for needed in projectCcu.ReferencedCcuNames do + if not (String.Equals(needed, name, StringComparison.OrdinalIgnoreCase)) then + place needed + + if placed.Add name then + ordered.Add entry + | _ -> () + + visiting.Remove name |> ignore + + for _, delayed in takenCcus do + place delayed.AssemblyName + + let g = tcImports.GetTcGlobals() - let phase2s = resolved |> List.map (registerDll keys) + for projectCcu, delayed in ordered do + let bound = projectCcu.GetCcu(g, resolve) + delayed.Fixup bound + boundCcus[delayed.AssemblyName] <- bound fixupOrphanCcus () diff --git a/src/Compiler/Driver/CompilerImports.fsi b/src/Compiler/Driver/CompilerImports.fsi index 5cf0f846e25..479dd45fc34 100644 --- a/src/Compiler/Driver/CompilerImports.fsi +++ b/src/Compiler/Driver/CompilerImports.fsi @@ -104,6 +104,21 @@ module internal SharedImportedCcus = val clear: unit -> unit +/// A project's contents already imported, for a reader to bind against its own ccus +type IImportedProjectCcu = + + /// Names this build, which a key pins instead of a file + abstract Stamp: int64 + + /// Every ccu this project imports. A reader binds the taken ones among them before binding this one. + abstract ReferencedCcuNames: string list + + abstract CanBeTaken: bool + + /// A copy of the tree with its non-local references re-pointed through `resolve`, as unpickling would + /// have done. Readers resolving every name alike share a copy. + abstract GetCcu: callerTcGlobals: TcGlobals * resolve: (string -> CcuThunk option) -> CcuThunk + /// Represents a resolved imported binary [] type ImportedBinary = diff --git a/src/Compiler/Service/BackgroundCompiler.fs b/src/Compiler/Service/BackgroundCompiler.fs index 50f9881260f..72dfcbf996b 100644 --- a/src/Compiler/Service/BackgroundCompiler.fs +++ b/src/Compiler/Service/BackgroundCompiler.fs @@ -466,20 +466,33 @@ type internal BackgroundCompiler incrementalBuildersCache.TryGetAny(AnyCallerThread, options) |> Option.map (fun x -> x.GetOrComputeValue()) + let setBuilderNode (options, userOpName) = + let getBuilderNode = GraphNode(CreateOneIncrementalBuilder(options, userOpName)) + incrementalBuildersCache.Set(AnyCallerThread, options, getBuilderNode) + getBuilderNode + + /// Replaces the cached build, for a caller that has decided it is stale. let createBuilderNode (options, userOpName, ct: CancellationToken) = lock gate (fun () -> if ct.IsCancellationRequested then GraphNode.FromResult(None, [||]) else - let getBuilderNode = GraphNode(CreateOneIncrementalBuilder(options, userOpName)) - incrementalBuildersCache.Set(AnyCallerThread, options, getBuilderNode) - getBuilderNode) + setBuilderNode (options, userOpName)) + + /// Without this second look under the gate, callers arriving together each build the project. + let getOrCreateBuilderNode (options, userOpName, ct: CancellationToken) = + lock gate (fun () -> + if ct.IsCancellationRequested then + GraphNode.FromResult(None, [||]) + else + match tryGetBuilderNode options with + | Some getBuilderNode -> getBuilderNode + | None -> setBuilderNode (options, userOpName)) - let createAndGetBuilder (options, userOpName) = + let getBuilderFrom (getBuilderNode: _ * _ * CancellationToken -> GraphNode<_>) (options, userOpName) = async { let! ct = Async.CancellationToken - let getBuilderNode = createBuilderNode (options, userOpName, ct) - return! getBuilderNode.GetOrComputeValue() + return! (getBuilderNode (options, userOpName, ct)).GetOrComputeValue() } let getOrCreateBuilder (options, userOpName) : Async = @@ -502,8 +515,8 @@ type internal BackgroundCompiler let key = (sourceFile, 0L, options) checkFileInProjectCache.RemoveAnySimilar(ltok, key))) - return! createAndGetBuilder (options, userOpName) - | _ -> return! createAndGetBuilder (options, userOpName) + return! getBuilderFrom createBuilderNode (options, userOpName) + | _ -> return! getBuilderFrom getOrCreateBuilderNode (options, userOpName) } let getSimilarOrCreateBuilder (options, userOpName) = diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index 4f02bda91e7..b156442491f 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -3,6 +3,7 @@ namespace FSharp.Compiler.CodeAnalysis open System +open System.Collections.Concurrent open System.Collections.Generic open System.Collections.Immutable open System.Diagnostics @@ -17,6 +18,7 @@ open FSharp.Compiler.CheckBasics open FSharp.Compiler.CheckDeclarations open FSharp.Compiler.CompilerConfig open FSharp.Compiler.CompilerDiagnostics +open FSharp.Compiler.CompilerGlobalState open FSharp.Compiler.CompilerImports open FSharp.Compiler.CompilerOptions open FSharp.Compiler.CreateILModule @@ -492,10 +494,10 @@ type FrameworkImportsCacheKey = interface ICacheKey with member this.GetKey() = - this |> function FrameworkImportsCacheKey(assemblyName=a;importReuseKey=c) -> if c.CheckNullness then a + "CheckNulls" else a + this |> function FrameworkImportsCacheKey(assemblyName=a;importReuseKey=c) -> if c.ImportsNullness then a + "CheckNulls" else a member this.GetLabel() = - this |> function FrameworkImportsCacheKey(assemblyName=a;importReuseKey=c) -> if c.CheckNullness then a + "CheckNulls" else a + this |> function FrameworkImportsCacheKey(assemblyName=a;importReuseKey=c) -> if c.ImportsNullness then a + "CheckNulls" else a member this.GetVersion() = this @@ -561,27 +563,7 @@ type FrameworkImportsCache(size) = // for each cached project. So here we create a new tcGlobals, with the existing framework values // and updated realsig and langversion let tcGlobals = - if tcGlobals.langVersion <> tcConfig.langVersion - || tcGlobals.realsig <> tcConfig.realsig then - TcGlobals( - tcGlobals.compilingFSharpCore, - tcGlobals.ilg, - tcGlobals.fslibCcu, - tcGlobals.directoryToResolveRelativePaths, - tcGlobals.isInteractive, - tcGlobals.checkNullness, - tcGlobals.useReflectionFreeCodeGen, - tcGlobals.tryFindSysTypeCcuHelper, - tcGlobals.emitDebugInfoInQuotations, - tcGlobals.noDebugAttributes, - tcGlobals.pathMap, - tcConfig.langVersion, - tcConfig.realsig, - tcConfig.compilationMode - ) - - else - tcGlobals + tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode) return tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolved } @@ -633,13 +615,100 @@ module Utilities = /// as a cross-assembly reference. Note the assembly has not been generated on disk, so this is /// a virtualized view of the assembly contents as computed by background checking. [] -type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, generatedCcu: CcuThunk, outfile, topAttrs, assemblyName, ilAssemRef) = - - let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents +type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals: TcGlobals, generatedCcu: CcuThunk, outfile, topAttrs, assemblyName, ilAssemRef, referencedCcuNames: string list option) = + // Nothing may ever ask for the bytes, and building them walks the whole signature let sigData = - let _sigDataAttributes, sigDataResources = EncodeSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, true) - GetResourceNameAndSignatureDataFuncs sigDataResources + lazy + let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents + + let _sigDataAttributes, sigDataResources = + EncodeSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, true) + + GetResourceNameAndSignatureDataFuncs sigDataResources + + let stamp = newStamp () + + /// As WriteSignatureData computes it, and here so a bad path fails where the project is built. + let sourceCodeDirectory = + if String.IsNullOrEmpty tcConfig.implicitIncludeDir then + "" + else + tcConfig.implicitIncludeDir + |> FileSystem.GetFullPathShim + |> Internal.Utilities.PathMap.applyDir tcGlobals.pathMap + + /// Nothing evicts, and past the cap a reader still gets a correct tree without keeping it. + let maxBoundCopies = 8 + + /// Each copy with what its non-local names were bound to. Readers sharing one agree on every assembly + /// it mentions, which is why one of their TcGlobals serves below. + let boundCopies = ResizeArray() + + /// What u_ccuref does to pickled names, done to the tree directly. + let bindTree (readerTcGlobals: TcGlobals) (resolve: string -> CcuThunk option) = + let boundTo = Dictionary(StringComparer.OrdinalIgnoreCase) + + // The thunk may still be delayed, so the reference is taken rather than fixed up. A name the + // reader does not have keeps ours: it has no second copy to disagree with. + let ccuRebind = + Some(fun (ccu: CcuThunk) -> + match boundTo.TryGetValue ccu.AssemblyName with + | true, (already, _) -> already + | _ -> + let entry = + match resolve ccu.AssemblyName with + | Some readers -> readers, true + | None -> ccu, false + + boundTo[ccu.AssemblyName] <- entry + fst entry) + + let viewedCcu = CcuThunk.CreateDelayed assemblyName + + let ilScopeRef = ILScopeRef.Assembly ilAssemRef + + let remapping = + MakeExportRemappingWith ccuRebind viewedCcu generatedCcu.Contents + + let contents = + ApplyExportRemappingToEntityLeavingAssembly tcGlobals remapping ilScopeRef generatedCcu.Contents + |> PruneExportedSignatureInPlace + + let ccuData: CcuData = + { + ILScopeRef = ilScopeRef + Stamp = newStamp () + FileName = Some outfile + QualifiedName = Some ilScopeRef.QualifiedName + SourceCodeDirectory = sourceCodeDirectory + IsFSharp = true + Contents = contents +#if !NO_TYPEPROVIDERS + InvalidateEvent = (Event()).Publish + IsProviderGenerated = false + // Unreachable: such a project reports its assembly data as unavailable + ImportProvidedType = (fun _ -> error (InternalError("a shared project reference cannot import provided types", range0))) +#endif + // No reader behind a project reference, so nothing can be disposed under a consumer + TryGetILModuleDef = (fun () -> None) + UsesFSharp20PlusQuotations = generatedCcu.UsesFSharp20PlusQuotations + // The reader's: linkage keys are matched against its entities through here + MemberSignatureEquality = (fun ty1 ty2 -> typeEquivAux EraseAll readerTcGlobals ty1 ty2) + // As GetRawTypeForwarders does for the pickled path + TypeForwarders = CcuTypeForwarderTable.Empty + XmlDocumentationInfo = None + CSharpStyleExtensionMembersCache = ConcurrentDictionary(1, 0) + } + + viewedCcu.Fixup(CcuThunk.Create(assemblyName, ccuData)) + + // Sorted, so two builds of the same tree give lists that compare element-wise + let bindings = + [ for KeyValue(name, (ccu, wasResolved)) in boundTo -> name, ccu, wasResolved ] + |> List.sortWith (fun (a, _, _) (b, _, _) -> String.CompareOrdinal(a, b)) + + viewedCcu, bindings let autoOpenAttrs, ivtAttrs = let mutable autoOpen = [] @@ -659,11 +728,59 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, generate List.rev autoOpen, List.rev ivt + interface IImportedProjectCcu with + member _.Stamp = stamp + + member _.ReferencedCcuNames = defaultArg referencedCcuNames [] + + member _.GetCcu(callerTcGlobals: TcGlobals, resolve) = + let matches (_, bindings) = + bindings + |> List.forall (fun (name, ccu, wasResolved) -> + match resolve name, wasResolved with + | Some ccuR, true -> obj.ReferenceEquals(ccuR, ccu) + | None, false -> true + | _ -> false) + + // Matching and building take the reader's own lock, so neither may run while this is held + let existingCopy () = + lock boundCopies (fun () -> boundCopies.ToArray()) |> Array.tryFind matches + + match existingCopy () with + | Some(ccu, _) -> ccu + | None -> + let ccu, bindings = bindTree callerTcGlobals resolve + + // Check and publish in one step, and not with the check above: it resolves through the reader + let sameBindings (other: (string * CcuThunk * bool) list) = + List.length other = List.length bindings + && List.forall2 + (fun (n1: string, c1: CcuThunk, r1) (n2: string, c2: CcuThunk, r2) -> + String.Equals(n1, n2, StringComparison.OrdinalIgnoreCase) + && obj.ReferenceEquals(c1, c2) + && r1 = r2) + other + bindings + + lock boundCopies (fun () -> + match boundCopies |> Seq.tryFind (snd >> sameBindings) with + | Some(shared, _) -> shared + | None -> + if boundCopies.Count < maxBoundCopies then + boundCopies.Add((ccu, bindings)) + + ccu) + + member _.CanBeTaken = + referencedCcuNames.IsSome + // Such a project gives a consumer no ccu at all, so taking it would change what compiles + && tcConfig.GenerateSignatureData + interface IRawFSharpAssemblyData with member _.GetAutoOpenAttributes() = autoOpenAttrs member _.GetInternalsVisibleToAttributes() = ivtAttrs member _.TryGetILModuleDef() = None - member _.GetRawFSharpSignatureData(_m, _ilShortAssemName, _filename) = sigData + member _.GetRawFSharpSignatureData(_m, _ilShortAssemName, _filename) = sigData.Force() member _.GetRawFSharpOptimizationData(_m, _ilShortAssemName, _filename) = [ ] member _.GetRawTypeForwarders() = mkILExportedTypes [] // TODO: cross-project references with type forwarders member _.ShortAssemblyName = assemblyName @@ -866,7 +983,14 @@ module IncrementalBuilderHelpers = if tcState.CreatesGeneratedProvidedTypes || hasTypeProviderAssemblyAttrib then ProjectAssemblyDataResult.Unavailable true else - ProjectAssemblyDataResult.Available (RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, generatedCcu, outfile, topAttrs, assemblyName, ilAssemRef) :> IRawFSharpAssemblyData) + let referencedCcuNames = + computedBoundModels + |> Seq.tryHead + |> Option.map (fun boundModel -> + boundModel.TcImports.GetCcusInDeclOrder() + |> List.map (fun ccu -> ccu.AssemblyName)) + + ProjectAssemblyDataResult.Available (RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, generatedCcu, outfile, topAttrs, assemblyName, ilAssemRef, referencedCcuNames) :> IRawFSharpAssemblyData) with exn -> errorRecoveryNoRange exn ProjectAssemblyDataResult.Unavailable true diff --git a/src/Compiler/Service/IncrementalBuild.fsi b/src/Compiler/Service/IncrementalBuild.fsi index 03c37da8216..ed333784832 100644 --- a/src/Compiler/Service/IncrementalBuild.fsi +++ b/src/Compiler/Service/IncrementalBuild.fsi @@ -150,10 +150,12 @@ type internal RawFSharpAssemblyDataBackedByLanguageService = outfile: string * topAttrs: TopAttribs * assemblyName: string * - ilAssemRef: IL.ILAssemblyRef -> + ilAssemRef: IL.ILAssemblyRef * + referencedCcuNames: string list option -> RawFSharpAssemblyDataBackedByLanguageService interface IRawFSharpAssemblyData + interface IImportedProjectCcu /// Manages an incremental build graph for the build of an F# project [] diff --git a/src/Compiler/Service/TransparentCompiler.fs b/src/Compiler/Service/TransparentCompiler.fs index 691dde3e802..99c068b2c31 100644 --- a/src/Compiler/Service/TransparentCompiler.fs +++ b/src/Compiler/Service/TransparentCompiler.fs @@ -968,28 +968,7 @@ type internal TransparentCompiler // for each cached project. So here we create a new tcGlobals, with the existing framework values // and updated realsig and langversion let tcGlobals = - if - tcGlobals.langVersion <> tcConfig.langVersion - || tcGlobals.realsig <> tcConfig.realsig - then - TcGlobals( - tcGlobals.compilingFSharpCore, - tcGlobals.ilg, - tcGlobals.fslibCcu, - tcGlobals.directoryToResolveRelativePaths, - tcGlobals.isInteractive, - tcGlobals.checkNullness, - tcGlobals.useReflectionFreeCodeGen, - tcGlobals.tryFindSysTypeCcuHelper, - tcGlobals.emitDebugInfoInQuotations, - tcGlobals.noDebugAttributes, - tcGlobals.pathMap, - tcConfig.langVersion, - tcConfig.realsig, - tcConfig.compilationMode - ) - else - tcGlobals + tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode) // Note we are not calling diagnosticsLogger.GetDiagnostics() anywhere for this task. // This is ok because not much can actually go wrong here. @@ -1871,7 +1850,9 @@ type internal TransparentCompiler bootstrapInfo.OutFile, topAttrs, bootstrapInfo.AssemblyName, - ilAssemRef + ilAssemRef, + // Only the background compiler offers contents in imported form + None ) :> IRawFSharpAssemblyData ) diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 24b2e645bfb..f46fa81668a 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -1178,6 +1178,33 @@ type TcGlobals( member _.realsig = realsig + member g.WithLanguageSettings(newLangVersion, newRealsig, newCompilationMode) = + if + newLangVersion = langVersion + && newRealsig = realsig + && newCompilationMode = compilationMode + then + g + else + let copy = + TcGlobals( + compilingFSharpCore, + ilg, + fslibCcu, + directoryToResolveRelativePaths, + isInteractive, + checkNullness, + useReflectionFreeCodeGen, + tryFindSysTypeCcuHelper, + emitDebugInfoInQuotations, + noDebugAttributes, + pathMap, + newLangVersion, + newRealsig, + newCompilationMode) + + copy + member _.unionCaseRefEq x y = primUnionCaseRefEq compilingFSharpCore fslibCcu x y member _.valRefEq x y = primValRefEq compilingFSharpCore fslibCcu x y diff --git a/src/Compiler/TypedTree/TcGlobals.fsi b/src/Compiler/TypedTree/TcGlobals.fsi index 8356b16ccfc..f07ec4a53a1 100644 --- a/src/Compiler/TypedTree/TcGlobals.fsi +++ b/src/Compiler/TypedTree/TcGlobals.fsi @@ -156,6 +156,10 @@ type internal TcGlobals = static member IsInEmbeddableKnownSet: name: string -> bool + /// The same framework import at another project's language settings; every entity is shared. + member WithLanguageSettings: + newLangVersion: Features.LanguageVersion * newRealsig: bool * newCompilationMode: CompilationMode -> TcGlobals + member directoryToResolveRelativePaths: string member noDebugAttributes: bool diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remap.fs b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs index 68c60b4dd98..6970933f64f 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remap.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs @@ -136,6 +136,9 @@ module internal TypeRemapping = /// Remove existing trait solutions? removeTraitSolutions: bool + + /// Set only while a tree is rebuilt for another project to read. + ccuRebind: (CcuThunk -> CcuThunk) option } let emptyRemap = @@ -144,6 +147,7 @@ module internal TypeRemapping = tyconRefRemap = emptyTyconRefRemap valRemap = ValMap.Empty removeTraitSolutions = false + ccuRebind = None } type Remap with @@ -159,13 +163,37 @@ module internal TypeRemapping = } let isRemapEmpty remap = - isNil remap.tpinst && remap.tyconRefRemap.IsEmpty && remap.valRemap.IsEmpty + isNil remap.tpinst + && remap.tyconRefRemap.IsEmpty + && remap.valRemap.IsEmpty + && remap.ccuRebind.IsNone let rec instTyparRef tpinst ty tp = match tpinst with | [] -> ty | (tpR, tyR) :: t -> if typarEq tp tpR then tyR else instTyparRef t ty tp + let rebindTyconRef (tyenv: Remap) (tcref: TyconRef) = + match tyenv.ccuRebind, tcref with + | Some rebind, ERefNonLocal(NonLocalEntityRef(ccu, path)) -> + let ccuR = rebind ccu + + // Reference identity, not ccuEq: the thunk is still delayed here, and ccuEq calls an + // unresolved thunk equal to anything of the same name + if obj.ReferenceEquals(ccu, ccuR) then + tcref + else + ERefNonLocal(NonLocalEntityRef(ccuR, path)) + | _ -> tcref + + /// Table first: a reference it rewrites is one of the project's own, already where it needs to be. + let remapOrRebindTyconRef (tyenv: Remap) tcref = + match tyenv.tyconRefRemap.TryFind tcref with + | Some tcrefR -> tcrefR + // A field test rather than a call that returns its argument, for the remaps that never rebind + | None when tyenv.ccuRebind.IsNone -> tcref + | None -> rebindTyconRef tyenv tcref + let remapTyconRef (tcmap: TyconRefMap<_>) tcref = match tcmap.TryFind tcref with | Some tcref -> tcref @@ -195,21 +223,31 @@ module internal TypeRemapping = match tyenv.tyconRefRemap.TryFind tcref with | Some tcrefR -> TType_app(tcrefR, remapTypesAux tyenv tinst, flags) | None -> - match tinst with - | [] -> ty // optimization to avoid re-allocation of TType_app node in the common case - | _ -> - // avoid reallocation on idempotent + // instType reaches here on every generic instantiation and never rebinds + match tyenv.ccuRebind with + | None -> + match tinst with + | [] -> ty // optimization to avoid re-allocation of TType_app node in the common case + | _ -> + // avoid reallocation on idempotent + let tinstR = remapTypesAux tyenv tinst + + if tinst === tinstR then + ty + else + TType_app(tcref, tinstR, flags) + | Some _ -> + let tcrefR = rebindTyconRef tyenv tcref let tinstR = remapTypesAux tyenv tinst - if tinst === tinstR then + if tinst === tinstR && tcref === tcrefR then ty else - TType_app(tcref, tinstR, flags) + TType_app(tcrefR, tinstR, flags) | TType_ucase(UnionCaseRef(tcref, n), tinst) -> - match tyenv.tyconRefRemap.TryFind tcref with - | Some tcrefR -> TType_ucase(UnionCaseRef(tcrefR, n), remapTypesAux tyenv tinst) - | None -> TType_ucase(UnionCaseRef(tcref, n), remapTypesAux tyenv tinst) + // Rebuilt either way, so unlike the cases around it nothing is kept by telling them apart + TType_ucase(UnionCaseRef(remapOrRebindTyconRef tyenv tcref, n), remapTypesAux tyenv tinst) | TType_anon(anonInfo, l) as ty -> let tupInfoR = remapTupInfoAux tyenv anonInfo.TupInfo @@ -250,7 +288,14 @@ module internal TypeRemapping = | Measure.Const(entityRef, m) -> match tyenv.tyconRefRemap.TryFind entityRef with | Some tcref -> Measure.Const(tcref, m) - | None -> unt + | None when tyenv.ccuRebind.IsNone -> unt + | None -> + let tcrefR = rebindTyconRef tyenv entityRef + + if entityRef === tcrefR then + unt + else + Measure.Const(tcrefR, m) | Measure.Prod(u1, u2, m) -> Measure.Prod(remapMeasureAux tyenv u1, remapMeasureAux tyenv u2, m) | Measure.RationalPower(u, q) -> Measure.RationalPower(remapMeasureAux tyenv u, q) | Measure.Inv u -> Measure.Inv(remapMeasureAux tyenv u) @@ -389,7 +434,7 @@ module internal TypeRemapping = and remapNonLocalValRef tyenv (nlvref: NonLocalValOrMemberRef) = let eref = nlvref.EnclosingEntity - let erefR = remapTyconRef tyenv.tyconRefRemap eref + let erefR = remapOrRebindTyconRef tyenv eref let vlink = nlvref.ItemKey let vlinkR = remapValLinkage tyenv vlink @@ -464,6 +509,7 @@ module internal TypeRemapping = tpinst = tpinst valRemap = ValMap.Empty removeTraitSolutions = false + ccuRebind = None } // entry points for "typar -> TType" instantiation diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi b/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi index 04cc615a670..9615e72dc7c 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.Remap.fsi @@ -113,7 +113,8 @@ module internal TypeRemapping = { tpinst: TyparInstantiation valRemap: ValRemap tyconRefRemap: TyconRefRemap - removeTraitSolutions: bool } + removeTraitSolutions: bool + ccuRebind: (CcuThunk -> CcuThunk) option } static member Empty: Remap @@ -128,6 +129,9 @@ module internal TypeRemapping = /// Remap a reference to a type definition using the given remapping substitution val remapTyconRef: TyconRefMap -> TyconRef -> TyconRef + /// As remapTyconRef, re-pointing what the table does not rewrite at the reader's ccu of the same name + val remapOrRebindTyconRef: Remap -> TyconRef -> TyconRef + /// Remap a reference to a union case using the given remapping substitution val remapUnionCaseRef: TyconRefMap -> UnionCaseRef -> UnionCaseRef diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs index d9fd96da9ed..56f744d94a7 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs @@ -104,6 +104,7 @@ module internal SignatureOps = tpinst = emptyTyparInst tyconRefRemap = TyconRefMap.OfList mrpi.RepackagedEntities removeTraitSolutions = false + ccuRebind = None } //-------------------------------------------------------------------------- @@ -698,7 +699,9 @@ module internal SignatureOps = // accessed via non local references. //-------------------------------------------------------------------------- - let MakeExportRemapping viewedCcu (mspec: ModuleOrNamespace) = + /// Carried from the start, not added to the result: tryRescopeVal below rewrites the types inside each + /// ValLinkageFullKey through the accumulated remapping. + let MakeExportRemappingWith ccuRebind viewedCcu (mspec: ModuleOrNamespace) = let accEntityRemap (entity: Entity) acc = match tryRescopeEntity viewedCcu entity with @@ -722,10 +725,18 @@ module internal SignatureOps = let entities = allEntitiesOfModuleOrNamespaceTy mty let vs = allValsOfModuleOrNamespaceTy mty // Remap the entities first so we can correctly remap the types in the signatures of the ValLinkageFullKey's in the value references - let acc = List.foldBack accEntityRemap entities Remap.Empty + let start = + { Remap.Empty with + ccuRebind = ccuRebind + } + + let acc = List.foldBack accEntityRemap entities start let allRemap = List.foldBack accValRemap vs acc allRemap + let MakeExportRemapping viewedCcu mspec = + MakeExportRemappingWith None viewedCcu mspec + let updateSeqTypeIsPrefix (fsharpCoreMSpec: ModuleOrNamespace) = let findModuleOrNamespace (name: string) (entity: Entity) = if not entity.IsModuleOrNamespace then @@ -1654,13 +1665,48 @@ module internal ExprRemapping = tps', tmenvinner type RemapContext = - { g: TcGlobals; stackGuard: StackGuard } + { + g: TcGlobals + stackGuard: StackGuard - let mkRemapContext g stackGuard = { g = g; stackGuard = stackGuard } + /// Set only when the remapped tree is leaving the assembly it was checked in. See remapAccess. + rescopeAccessTo: ILScopeRef option + } + + let mkRemapContext g stackGuard = + { + g = g + stackGuard = stackGuard + rescopeAccessTo = None + } + + let mkRemapContextLeavingAssembly g stackGuard rescopeAccessTo = + { + g = g + stackGuard = stackGuard + rescopeAccessTo = Some rescopeAccessTo + } + + let remapCompPath (ctxt: RemapContext) (CompPath(scoref, _, path) as cpath) = + match ctxt.rescopeAccessTo with + | None -> cpath + // p_cpath does not write the syntactic access and u_cpath rebuilds it as Unknown + | Some ilScopeRef -> CompPath(rescopeILScopeRef ilScopeRef scoref, SyntaxAccess.Unknown, path) + + /// ILScopeRef.Local names the assembly being compiled, so a consumer reading a tree that still said + /// Local would take its `internal` for its own. u_ILScopeRef does this for the pickled form. + let remapAccess (ctxt: RemapContext) access = + match ctxt.rescopeAccessTo, access with + | None, _ + | _, TAccess [] -> access + | Some ilScopeRef, TAccess paths -> + paths + |> List.map (fun (CompPath(scoref, _, path)) -> CompPath(rescopeILScopeRef ilScopeRef scoref, SyntaxAccess.Unknown, path)) + |> TAccess let rec remapAttribImpl ctxt tmenv (Attrib(tcref, kind, args, props, isGetOrSetAttr, targets, m)) = Attrib( - remapTyconRef tmenv.tyconRefRemap tcref, + remapOrRebindTyconRef tmenv tcref, remapAttribKind tmenv kind, args |> List.map (remapAttribExpr ctxt tmenv), props @@ -1710,6 +1756,7 @@ module internal ExprRemapping = | Some dd -> Some { dd with + val_access = dd.val_access |> remapAccess ctxt val_declaring_entity = declaringEntityR val_repr_info = reprInfoR val_member_info = memberInfoR @@ -1721,7 +1768,7 @@ module internal ExprRemapping = and remapParentRef tyenv p = match p with | ParentNone -> ParentNone - | Parent x -> Parent(x |> remapTyconRef tyenv.tyconRefRemap) + | Parent x -> Parent(x |> remapOrRebindTyconRef tyenv) and mapImmediateValsAndTycons ft fv (x: ModuleOrNamespaceType) = let vals = x.AllValsAndMembers |> QueueList.map fv @@ -1998,13 +2045,13 @@ module internal ExprRemapping = and remapOp tmenv op = match op with - | TOp.Recd(ctor, tcref) -> TOp.Recd(ctor, remapTyconRef tmenv.tyconRefRemap tcref) - | TOp.UnionCaseTagGet tcref -> TOp.UnionCaseTagGet(remapTyconRef tmenv.tyconRefRemap tcref) + | TOp.Recd(ctor, tcref) -> TOp.Recd(ctor, remapOrRebindTyconRef tmenv tcref) + | TOp.UnionCaseTagGet tcref -> TOp.UnionCaseTagGet(remapOrRebindTyconRef tmenv tcref) | TOp.UnionCase ucref -> TOp.UnionCase(remapUnionCaseRef tmenv.tyconRefRemap ucref) | TOp.UnionCaseProof ucref -> TOp.UnionCaseProof(remapUnionCaseRef tmenv.tyconRefRemap ucref) - | TOp.ExnConstr ec -> TOp.ExnConstr(remapTyconRef tmenv.tyconRefRemap ec) - | TOp.ExnFieldGet(ec, n) -> TOp.ExnFieldGet(remapTyconRef tmenv.tyconRefRemap ec, n) - | TOp.ExnFieldSet(ec, n) -> TOp.ExnFieldSet(remapTyconRef tmenv.tyconRefRemap ec, n) + | TOp.ExnConstr ec -> TOp.ExnConstr(remapOrRebindTyconRef tmenv ec) + | TOp.ExnFieldGet(ec, n) -> TOp.ExnFieldGet(remapOrRebindTyconRef tmenv ec, n) + | TOp.ExnFieldSet(ec, n) -> TOp.ExnFieldSet(remapOrRebindTyconRef tmenv ec, n) | TOp.ValFieldSet rfref -> TOp.ValFieldSet(remapRecdFieldRef tmenv.tyconRefRemap rfref) | TOp.ValFieldGet rfref -> TOp.ValFieldGet(remapRecdFieldRef tmenv.tyconRefRemap rfref) | TOp.ValFieldGetAddr(rfref, readonly) -> TOp.ValFieldGetAddr(remapRecdFieldRef tmenv.tyconRefRemap rfref, readonly) @@ -2123,6 +2170,7 @@ module internal ExprRemapping = and remapRecdField ctxt tmenv x = { x with + rfield_access = x.rfield_access |> remapAccess ctxt rfield_type = x.rfield_type |> remapPossibleForallTyImpl ctxt tmenv rfield_pattribs = x.rfield_pattribs |> remapAttribs ctxt tmenv rfield_fattribs = x.rfield_fattribs |> remapAttribs ctxt tmenv @@ -2135,6 +2183,7 @@ module internal ExprRemapping = and remapUnionCase ctxt tmenv (x: UnionCase) = { x with + Accessibility = x.Accessibility |> remapAccess ctxt FieldTable = x.FieldTable |> remapRecdFields ctxt tmenv ReturnType = x.ReturnType |> remapType tmenv Attribs = x.Attribs |> remapAttribs ctxt tmenv @@ -2174,7 +2223,7 @@ module internal ExprRemapping = ProvidedType = info.ProvidedType.PApplyNoFailure(fun st -> let ctxt = - st.Context.RemapTyconRefs(unbox >> remapTyconRef tmenv.tyconRefRemap >> box >> (!!)) + st.Context.RemapTyconRefs(unbox >> remapOrRebindTyconRef tmenv >> box >> (!!)) ProvidedType.ApplyContext(st, ctxt)) } @@ -2205,7 +2254,7 @@ module internal ExprRemapping = and remapTyconExnInfo ctxt tmenv inp = match inp with - | TExnAbbrevRepr x -> TExnAbbrevRepr(remapTyconRef tmenv.tyconRefRemap x) + | TExnAbbrevRepr x -> TExnAbbrevRepr(remapOrRebindTyconRef tmenv x) | TExnFresh x -> TExnFresh(remapRecdFields ctxt tmenv x) | TExnAsmRepr _ | TExnNone -> inp @@ -2229,7 +2278,7 @@ module internal ExprRemapping = } { x with - ApparentEnclosingEntity = x.ApparentEnclosingEntity |> remapTyconRef tmenv.tyconRefRemap + ApparentEnclosingEntity = x.ApparentEnclosingEntity |> remapOrRebindTyconRef tmenv ImplementedSlotSigs = x.ImplementedSlotSigs |> List.map (remapSlotSig (remapAttribs ctxt tmenv) tmenv) } @@ -2389,7 +2438,7 @@ module internal ExprRemapping = opens |> List.map (fun od -> { od with - Modules = od.Modules |> List.map (remapTyconRef tmenv.tyconRefRemap) + Modules = od.Modules |> List.map (remapOrRebindTyconRef tmenv) Types = od.Types |> List.map (remapType tmenv) }) @@ -2441,65 +2490,37 @@ module internal ExprRemapping = // Entry points let remapAttrib g tmenv attrib = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapAttribImpl ctxt tmenv attrib let remapExpr g (compgen: ValCopyFlag) (tmenv: Remap) expr = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapExprImpl ctxt compgen tmenv expr let remapPossibleForallTy g tmenv ty = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapPossibleForallTyImpl ctxt tmenv ty let copyModuleOrNamespaceType g compgen mtyp = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) copyAndRemapAndBindModTy ctxt compgen Remap.Empty mtyp |> fst let copyExpr g compgen e = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapExprImpl ctxt compgen Remap.Empty e let copyImplFile g compgen e = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapImplFile ctxt compgen Remap.Empty e |> fst let instExpr g tpinst e = - let ctxt = - { - g = g - stackGuard = StackGuard("RemapExprStackGuardDepth") - } + let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapExprImpl ctxt CloneAll (mkInstRemap tpinst) e diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi index 5372d2a2511..0f0c68b4694 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fsi @@ -118,6 +118,11 @@ module internal SignatureOps = val MakeExportRemapping: CcuThunk -> ModuleOrNamespace -> Remap + /// As MakeExportRemapping, carrying the rebinding while the table is built, so the types inside each + /// ValLinkageFullKey are rewritten too + val MakeExportRemappingWith: + ccuRebind: (CcuThunk -> CcuThunk) option -> viewedCcu: CcuThunk -> mspec: ModuleOrNamespace -> Remap + /// Updates the IsPrefixDisplay to false for the Microsoft.FSharp.Collections.seq`1 entity val updateSeqTypeIsPrefix: fsharpCoreMSpec: ModuleOrNamespace -> unit @@ -241,10 +246,18 @@ module internal ExprRemapping = val mkRemapContext: TcGlobals -> StackGuard -> RemapContext + /// For a tree read as another assembly's contents; every accessibility is rescoped. + val mkRemapContextLeavingAssembly: + TcGlobals -> StackGuard -> rescopeAccessTo: FSharp.Compiler.AbstractIL.IL.ILScopeRef -> RemapContext + val tryStripLambdaN: int -> Expr -> (Val list list * Expr) option val tmenvCopyRemapAndBindTypars: (Attribs -> Attribs) -> Remap -> Typars -> Typars * Remap + val remapCompPath: RemapContext -> CompilationPath -> CompilationPath + + val remapAccess: RemapContext -> Accessibility -> Accessibility + val remapAttribs: RemapContext -> Remap -> Attribs -> Attribs val remapValData: RemapContext -> Remap -> ValData -> ValData diff --git a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs index 7ee5f290b23..1bd1e62e1f2 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fs @@ -999,11 +999,19 @@ module internal Rewriting = entity_tycon_repr = tyconReprR entity_tycon_tcaug = tyconTcaugR entity_modul_type = modulContentsR + entity_cpath = + match d.entity_cpath with + | Some cpath -> + let cpathR = remapCompPath ctxt cpath + if cpath === cpathR then d.entity_cpath else Some cpathR + | None -> None entity_opt_data = match d.entity_opt_data with | Some dd -> Some { dd with + entity_accessibility = dd.entity_accessibility |> remapAccess ctxt + entity_tycon_repr_accessibility = dd.entity_tycon_repr_accessibility |> remapAccess ctxt entity_tycon_abbrev = tyconAbbrevR entity_exn_info = exnInfoR } @@ -1021,6 +1029,38 @@ module internal Rewriting = let ctxt = mkRemapContext g (StackGuard("RemapExprStackGuardDepth")) remapTyconToNonLocal ctxt tmenv x + let ApplyExportRemappingToEntityLeavingAssembly g tmenv rescopeAccessTo x = + let ctxt = + mkRemapContextLeavingAssembly g (StackGuard("RemapExprStackGuardDepth")) rescopeAccessTo + + remapTyconToNonLocal ctxt tmenv x + + let PruneExportedSignatureInPlace (mspec: ModuleOrNamespace) = + let rec pruneEntity (entity: Entity) = + entity.entity_il_repr_cache <- null + pruneContents entity.ModuleOrNamespaceType + + and pruneContents (mty: ModuleOrNamespaceType) = + for v in mty.AllValsAndMembers do + match v.val_opt_data with + | Some optData -> + optData.val_defn <- None + optData.val_repr_info_for_display <- None + optData.arg_repr_info_for_display <- None + + match optData.val_other_xmldoc with + | Some doc when optData.val_xmldoc.IsEmpty -> optData.val_xmldoc <- doc + | _ -> () + + optData.val_other_xmldoc <- None + | None -> () + + for e in mty.AllEntities do + pruneEntity e + + pruneEntity mspec + mspec + (* Which constraints actually get compiled to .NET constraints? *) let isCompiledOrWitnessPassingConstraint (g: TcGlobals) cx = match cx with diff --git a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fsi b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fsi index 109cb403c38..2f4bd2db276 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Transforms.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.Transforms.fsi @@ -181,6 +181,15 @@ module internal Rewriting = /// Make a remapping table for viewing a module or namespace 'from the outside' val ApplyExportRemappingToEntity: TcGlobals -> Remap -> ModuleOrNamespace -> ModuleOrNamespace + /// As ApplyExportRemappingToEntity, rescoping every accessibility, so nothing is left saying + /// ILScopeRef.Local and reading in the consumer as internal to its own assembly. + val ApplyExportRemappingToEntityLeavingAssembly: + TcGlobals -> Remap -> rescopeAccessTo: ILScopeRef -> ModuleOrNamespace -> ModuleOrNamespace + + /// Bring a just-exported signature to the shape unpickling produces: no value definitions, no + /// display-only data and no compiled-representation cache. Mutates a tree from the above. + val PruneExportedSignatureInPlace: ModuleOrNamespace -> ModuleOrNamespace + [] module internal TupleCompilation = diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index e043d8554ad..bc344d4936d 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -46,6 +46,7 @@ + diff --git a/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs b/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs new file mode 100644 index 00000000000..d51987c8acf --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs @@ -0,0 +1,657 @@ +module FSharp.Compiler.Service.Tests.ProjectReferenceHandoverTests + +open Xunit +open System.IO +open System.Reflection +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.Diagnostics +open FSharp.Compiler.IO +open FSharp.Compiler.Service.Tests.Common +open FSharp.Compiler.Symbols +open FSharp.Compiler.TypedTree +open TestFramework + +// A referenced project can hand its contents to a consumer already imported instead of pickling them. +// Unpickling is what rewrites ILScopeRef.Local into the referenced assembly, so the handed-over form +// has to do the same: `internal` is a compilation path rooted at Local, and a consumer whose own paths +// are also Local would otherwise read the reference's internals as its own. +// +// Only the background compiler hands contents over, so these pin it rather than taking the suite default. +let private mkCheckerOn transparent share = + FSharpChecker.Create( + // the default is three, and these graphs are larger: an evicted builder is rebuilt with a fresh + // provider, which would look like a refused handover + projectCacheSize = 50, + shareImportedAssemblies = share, + enablePartialTypeChecking = false, + useTransparentCompiler = transparent + ) + +let private mkChecker share = mkCheckerOn false share + +let private writeSourceAs (extension: string) (source: string) = + let fileName = Path.ChangeExtension(getTemporaryFileName (), extension) + FileSystem.OpenFileForWriteShim(fileName).Write(source) + fileName + +let private writeSource source = writeSourceAs ".fs" source + +/// Options for one project of the given files, referencing the given already-built ones, output under +/// the given assembly name where one is asked for - a project whose contents are offered is registered +/// under that name, and a reference to it from elsewhere has to resolve to it +let private projectOptionsNamed (checker: FSharpChecker) assemblyName fileNames references extraOptions = + let baseName = + match assemblyName with + | Some name -> Path.Combine(Path.GetDirectoryName(getTemporaryFileName ()), name) + | None -> getTemporaryFileName () + + let dllName = Path.ChangeExtension(baseName, ".dll") + let projName = Path.ChangeExtension(baseName, ".fsproj") + let args = mkProjectCommandLineArgsSilent (dllName, fileNames) + let options = checker.GetProjectOptionsFromCommandLineArgs(projName, args) + + let options = + { options with + SourceFiles = fileNames + OtherOptions = + Array.concat + [ options.OtherOptions + [| for dll, _ in references -> "-r:" + dll |] + extraOptions ] + ReferencedProjects = + [| for dll, opts in references -> FSharpReferencedProject.FSharpReference(dll, opts) |] } + + dllName, options + +let private projectOptionsOfFiles checker fileNames references extraOptions = + projectOptionsNamed checker None fileNames references extraOptions + +/// Options for one project of a single implementation file +let private projectOptions (checker: FSharpChecker) source references extraOptions = + projectOptionsOfFiles checker [| writeSource source |] references extraOptions + +/// FSharpAssembly holds the ccu it wraps but does not expose it. The contents rather than the thunk: each +/// reader holds a thunk of its own around the one imported form, and the form is what is shared. +let private ccuOf (assembly: FSharpAssembly) = + assembly.GetType().GetFields(BindingFlags.Instance ||| BindingFlags.NonPublic ||| BindingFlags.Public) + |> Array.pick (fun field -> + match field.GetValue assembly with + | :? CcuThunk as ccu -> Some ccu.Contents + | _ -> None) + +/// The ccu the given project ended up with for one of its references +let private referencedCcu (checker: FSharpChecker) (options: FSharpProjectOptions) name = + let results = checker.ParseAndCheckProject options |> Async.RunSynchronously + + results.ProjectContext.GetReferencedAssemblies() + |> List.find (fun assembly -> assembly.SimpleName = name) + |> ccuOf + +let private errorsIn (checker: FSharpChecker) (options: FSharpProjectOptions) = + let results = checker.ParseAndCheckProject options |> Async.RunSynchronously + + results.Diagnostics + |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + +let private librarySource = + """ +module Library + +let publicValue = 1 +let internal secretValue = 2 +type internal SecretType = { S: int } +type Colour = internal Red | Green +type internal SecretClass() = + member _.M = 3 +""" + +let private consumerOf body = "module Consumer\n" + body + "\n" + +/// Enough on its own where the shape of the internal does not matter +let private useInternalValue = "let useValue = Library.secretValue" + +[] +[] +[">] +[] +[] +let ``An internal of a handed-over project is not visible to a consumer`` (useInternal: string) = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [||] + let _, consumer = projectOptions checker (consumerOf useInternal) [ library ] [||] + + Assert.NotEmpty(errorsIn checker consumer) + +[] +let ``Handed-over contents keep the public surface usable`` () = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [||] + + let _, consumer = + projectOptions checker (consumerOf "let usePublic = Library.publicValue") [ library ] [||] + + Assert.Empty(errorsIn checker consumer) + +[] +let ``A consumer on another framework import layer takes the contents`` () = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + // Reading nullable-reference metadata keys a different import layer, so this consumer's framework + // members - FSharp.Core's included - are not the ones the library was checked against. It takes the + // contents anyway: every non-local reference in them is bound to the ccu this consumer resolves that + // name to, which is what unpickling would have done for it. + let _, sameLayer = + projectOptions checker (consumerOf "let usePublic = Library.publicValue + 1") [ library ] [||] + + let otherLayer body = + projectOptions checker (consumerOf body) [ library ] [| "--langversion:9.0"; "--checknulls+" |] + |> snd + + let firstOther = otherLayer "let useOnce = Library.publicValue + 1" + let secondOther = otherLayer "let useTwice = Library.publicValue + 2" + + Assert.Empty(errorsIn checker sameLayer) + Assert.Empty(errorsIn checker firstOther) + + // Both are on that other layer, so one bound copy serves them: were the contents not taken they would + // each have unpickled one of their own + Assert.Same(referencedCcu checker firstOther libraryName, referencedCcu checker secondOther libraryName) + + // And that copy cannot also serve the layer the library was checked on: they disagree about + // FSharp.Core, and each must see its own + Assert.NotSame(referencedCcu checker sameLayer libraryName, referencedCcu checker firstOther libraryName) + +/// Binding the contents to the reader's own ccus must not make anything visible that a consumer of the +/// compiled assembly would not see +[] +let ``An internal is not visible to a consumer on another layer either`` () = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [||] + + let _, otherLayer = + projectOptions checker (consumerOf useInternalValue) [ library ] [| "--langversion:9.0"; "--checknulls+" |] + + Assert.NotEmpty(errorsIn checker otherLayer) + +[] +let ``Type identity survives a chain of handed-over project references`` () = + let checker = mkChecker true + + let leaf = + projectOptions + checker + """ +module Leaf + +let publicLeaf = 1 +let internal secretLeaf = 2 +type LeafType = { X: int } +""" + [] + [||] + + let middle = + projectOptions + checker + """ +module Middle + +let publicMiddle = Leaf.publicLeaf +let makeLeafType () : Leaf.LeafType = { X = 1 } +""" + [ leaf ] + [||] + + // As a build passes project references on transitively + let _, consumer = + projectOptions + checker + """ +module Consumer + +let useMiddle = Middle.publicMiddle +let useLeafThroughMiddle = (Middle.makeLeafType ()).X +let useLeafDirectly : Leaf.LeafType = { X = 2 } +""" + [ middle; leaf ] + [||] + + // The leaf type reached through the middle project must be the one the consumer imports itself + Assert.Empty(errorsIn checker consumer) + +/// Handing the contents over is what makes one imported form serve every consumer. Were the handover +/// to stop happening these would still type-check, so this is what holds the feature in place. +[] +[] +[] +let ``Consumers share one imported ccu only when contents are handed over`` share = + let checker = mkChecker share + let library = projectOptions checker librarySource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, first = + projectOptions checker (consumerOf "let first = Library.publicValue") [ library ] [||] + + let _, second = + projectOptions checker (consumerOf "let second = Library.publicValue") [ library ] [||] + + let firstCcu = referencedCcu checker first libraryName + let secondCcu = referencedCcu checker second libraryName + + if share then + Assert.Same(firstCcu, secondCcu) + else + Assert.NotSame(firstCcu, secondCcu) + +/// Importing IL metadata consults the settings in one place only - whether nullable-reference attributes +/// are read into the TAST - so two projects agreeing on that import one framework layer whatever their +/// language versions. Keying the layer on the version itself gave each of them a framework of its own, +/// and with it a second copy of every framework entity. +[] +let ``Projects on different language versions share one framework import`` () = + let checker = mkChecker true + + let ccuOfFSharpCore extraOptions = + let _, options = projectOptions checker (consumerOf "let value = 1") [] extraOptions + referencedCcu checker options "FSharp.Core" + + Assert.Same(ccuOfFSharpCore [| "--langversion:8.0" |], ccuOfFSharpCore [| "--langversion:9.0" |]) + +/// The framework import layer is keyed on what importing depends on, so projects that disagree about +/// nullable-reference metadata genuinely import different entities and must refuse each other. realsig is +/// not part of that key: it changes what a project emits, not what it imports. But a project whose +/// realsig differs from the one its layer was +/// first built for is handed a TcGlobals of its own over those very entities, and comparing the TcGlobals +/// rather than the layer refused it every handover - including from a project with the same setting, +/// which made how much of a solution shared depend on which project reached the layer first. +[] +let ``Consumers differing only in realsig share one imported ccu`` () = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [| "--realsig+" |] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, plain = + projectOptions checker (consumerOf "let first = Library.publicValue") [ library ] [||] + + let _, real = + projectOptions checker (consumerOf "let second = Library.publicValue") [ library ] [| "--realsig+" |] + + Assert.Empty(errorsIn checker plain) + Assert.Empty(errorsIn checker real) + Assert.Same(referencedCcu checker plain libraryName, referencedCcu checker real libraryName) + +/// The memo holds a pessimistic entry while a provider's own answer is being computed, so that a cycle +/// refuses rather than loops. A diamond re-reaches a project without a cycle, and must not read that entry. +[] +let ``A project reached twice through a diamond is still taken`` () = + let checker = mkChecker true + let leaf = projectOptions checker "module Leaf\nlet leaf = 1\n" [] [||] + let left = projectOptions checker "module Left\nlet left = Leaf.leaf\n" [ leaf ] [||] + let right = projectOptions checker "module Right\nlet right = Leaf.leaf\n" [ leaf ] [||] + + let join = + projectOptions checker "module Join\nlet join = Left.left + Right.right\n" [ left; right; leaf ] [||] + + let joinName = Path.GetFileNameWithoutExtension(fst join) + let references = [ join; left; right; leaf ] + + let _, first = projectOptions checker "module First\nlet x = Join.join\n" references [||] + let _, second = projectOptions checker "module Second\nlet y = Join.join\n" references [||] + + // Asking Join reaches Leaf through both Left and Right; the second ask must see the settled answer + Assert.Same(referencedCcu checker first joinName, referencedCcu checker second joinName) + +/// The offer used to require agreement about every assembly the offering project imports, so a +/// private implementation dependency - one the consumers never resolve, at any layer - refused it. +[] +let ``A dependency the consumer does not have does not refuse the offer`` () = + let checker = mkChecker true + + // outside the standard reference set, so only the library imports anything of this name + let privateDependency = "-r:" + typeof.Assembly.Location + + let library = projectOptions checker librarySource [] [| privateDependency |] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, first = + projectOptions checker (consumerOf "let first = Library.publicValue") [ library ] [||] + + let _, second = + projectOptions checker (consumerOf "let second = Library.publicValue") [ library ] [||] + + Assert.Empty(errorsIn checker first) + Assert.Same(referencedCcu checker first libraryName, referencedCcu checker second libraryName) + +/// The handed-over ccu is the offering project's own, not an entry in the shared cache, so consumers +/// racing each other must still land on the one object. +[] +let ``Consumers checked at once share one imported ccu`` () = + let checker = mkChecker true + let library = projectOptions checker librarySource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let consumers = + [ for i in 1..8 -> + projectOptions checker (consumerOf $"let use%d{i} = Library.publicValue") [ library ] [||] + |> snd ] + + let results = + consumers + |> List.map checker.ParseAndCheckProject + |> Async.Parallel + |> Async.RunSynchronously + + for r in results do + Assert.Empty(r.Diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error)) + + let ccus = + results + |> Array.map (fun r -> + r.ProjectContext.GetReferencedAssemblies() + |> List.find (fun a -> a.SimpleName = libraryName) + |> ccuOf) + + for ccu in ccus do + Assert.Same(ccus[0], ccu) + +/// Wide enough for the two paths to disagree somewhere: accessibility, abbreviations, generics, members, +/// fields, union cases, literals, inlining and documentation all travel differently between them. +let private surfaceSource = + """ +module Surface + +open System + +/// A documented literal +[] +let Answer = 42 + +let mutable counter = 0 + +/// A record with an internal field +type Record = + { Name: string + mutable Count: int + internal Hidden: int } + + /// A documented property + member this.Doubled = this.Count * 2 + + static member Create name = { Name = name; Count = 0; Hidden = 0 } + +/// A union with an internal case +type Shape = + | Circle of radius: float + | Rect of width: float * height: float + | internal Secret + +type Alias = Record + +type Generic<'T when 'T :> IComparable>(value: 'T) = + member _.Value = value + member _.Boxed = box value + +[] +type Base() = + abstract Describe: unit -> string + default _.Describe() = "base" + +exception CustomError of code: int + +type internal HiddenRecord = { X: int } + +type Mixed() = + member _.Public = 1 + member internal _.Internal = 2 + +module internal HiddenModule = + let value = 1 + +module Nested = + /// Inside a nested module + let helper (x: int) = x + 1 + + type Inner = { Value: int } + +[] +module Auto = + let inline addThem a b = a + b +""" + +/// Anything that throws is rendered rather than swallowed, so the two paths must also agree about that +let private safe (f: unit -> string) = + try + f () + with e -> + "<" + e.GetType().Name + ">" + +/// The text itself, not just XmlDocSig: the signature file's doc reaches a value through a different +/// field than its own, and only the text shows whether that one survived. +let private describeXmlDoc (doc: FSharpXmlDoc) = + match doc with + | FSharpXmlDoc.FromXmlText text -> "doc=" + String.concat " " text.UnprocessedLines + | FSharpXmlDoc.FromXmlFile(_, xmlSig) -> "docfile=" + xmlSig + | FSharpXmlDoc.None -> "" + +let private describeAccess (a: FSharpAccessibility) = + if a.IsPublic then "public" + elif a.IsInternal then "internal" + elif a.IsPrivate then "private" + else "?" + +let private describeSymbol (s: FSharpSymbol) = + let ctx = FSharpDisplayContext.Empty + + let details = + match s with + | :? FSharpEntity as e -> + [ describeAccess e.Accessibility + safe (fun () -> if e.IsFSharpAbbreviation then "abbrev=" + e.AbbreviatedType.Format ctx else "") + safe (fun () -> + match e.BaseType with + | Some b -> "base=" + b.Format ctx + | None -> "") + safe (fun () -> e.DeclaredInterfaces |> Seq.map (fun i -> i.Format ctx) |> String.concat ",") + safe (fun () -> e.XmlDocSig) + safe (fun () -> describeXmlDoc e.XmlDoc) ] + | :? FSharpMemberOrFunctionOrValue as v -> + [ describeAccess v.Accessibility + safe (fun () -> v.FullType.Format ctx) + (if v.IsMutable then "mutable" else "") + safe (fun () -> string v.InlineAnnotation) + safe (fun () -> + match v.LiteralValue with + | Some x -> "literal=" + string x + | None -> "") + safe (fun () -> v.XmlDocSig) + safe (fun () -> describeXmlDoc v.XmlDoc) ] + | :? FSharpField as f -> [ describeAccess f.Accessibility; safe (fun () -> f.FieldType.Format ctx) ] + | :? FSharpUnionCase as c -> + [ describeAccess c.Accessibility + safe (fun () -> c.Fields |> Seq.map (fun f -> f.FieldType.Format ctx) |> String.concat ",") ] + | _ -> [] + + String.concat "|" ( + [ s.GetType().Name; safe (fun () -> s.FullName); s.DisplayName ] + @ details + @ attribsOfSymbol s) + +/// Everything a host can see of a referenced project, however this build of it arrived +let private referencedSurface (checker: FSharpChecker) (options: FSharpProjectOptions) name = + let results = checker.ParseAndCheckProject options |> Async.RunSynchronously + + let assembly = + results.ProjectContext.GetReferencedAssemblies() + |> List.find (fun a -> a.SimpleName = name) + + allSymbolsInEntities true assembly.Contents.Entities + |> List.map describeSymbol + |> List.sort + |> Array.ofList + +/// The handed-over tree is meant to be what unpickling produces. The other tests pin single properties +/// of that; this one compares the whole surface a host sees, against a checker that cannot share and so +/// unpickles the same project. A field the pruning forgets shows up here and nowhere else. +[] +let ``A handed-over project presents the same surface as an unpickled one`` () = + let surfaceOf share = + let checker = mkChecker share + let library = projectOptions checker surfaceSource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, consumer = + projectOptions checker (consumerOf "let useIt = Surface.Answer") [ library ] [||] + + Assert.Empty(errorsIn checker consumer) + referencedSurface checker consumer libraryName + + let unpickled = surfaceOf false + let handedOver = surfaceOf true + + Assert.Equal(unpickled, handedOver) + + +/// A project with a signature file exports what the signature says, and signature conformance hands the +/// signature's documentation to the implementation as a doc held apart from the value's own. Neither path +/// carries that second doc to a consumer - the comparison below is what says so - but the implementation's +/// own documentation does travel, and the guard keeps this from passing on two empty surfaces. +[] +let ``A handed-over project with a signature file presents the same surface as an unpickled one`` () = + let signatureSource = + """ +module Documented + +/// The answer and where it came from +val answer: int + +/// Doubles its argument +val twice: x: int -> int +""" + + let implementationSource = + """ +module Documented + +let answer = 42 + +/// Doubles it, said in the implementation +let twice x = x * 2 +""" + + let surfaceOf share = + let checker = mkChecker share + + let files = + [| writeSourceAs ".fsi" signatureSource + writeSourceAs ".fs" implementationSource |] + + let library = projectOptionsOfFiles checker files [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, consumer = + projectOptions checker (consumerOf "let useIt = Documented.answer") [ library ] [||] + + Assert.Empty(errorsIn checker consumer) + referencedSurface checker consumer libraryName + + let unpickled = surfaceOf false + let handedOver = surfaceOf true + + Assert.Equal(unpickled, handedOver) + + // Both paths losing the doc would satisfy the comparison above and pin nothing + Assert.Contains(handedOver, fun (s: string) -> s.Contains "Doubles it, said in the implementation") + +/// Only the background compiler offers contents in imported form: TransparentCompiler builds the same +/// assembly data with nothing to offer, so its consumers each unpickle a copy. Nothing else says so, and +/// a later change that started offering there would be a silent one. +[] +let ``The transparent compiler does not hand contents over`` () = + let checker = mkCheckerOn true true + let library = projectOptions checker librarySource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + + let _, first = + projectOptions checker (consumerOf "let first = Library.publicValue") [ library ] [||] + + let _, second = + projectOptions checker (consumerOf "let second = Library.publicValue") [ library ] [||] + + Assert.Empty(errorsIn checker first) + Assert.Empty(errorsIn checker second) + Assert.NotSame(referencedCcu checker first libraryName, referencedCcu checker second libraryName) + +/// Compiles a real assembly, so that what a consumer imports from it comes from pickled bytes on disk +/// rather than from another project of the graph. +let private compileDll (checker: FSharpChecker) name source references = + let dll = Path.Combine(Path.GetDirectoryName(getTemporaryFileName ()), name + ".dll") + + let args = + [| yield "fsc.exe" + yield "--target:library" + yield "--noframework" + yield "-o:" + dll + for r in mkStandardProjectReferences () -> "-r:" + r + for r in references -> "-r:" + r + yield writeSource source |] + + let diagnostics, exn = checker.Compile(args) |> Async.RunSynchronously + Assert.Empty(diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error)) + Assert.True(exn.IsNone, string exn) + dll + +/// An assembly read from disk carries its signature pickled, and unpickling it resolves the names it +/// mentions against what the consumer has registered. One of those names can be a project whose contents +/// were offered, whose ccu stands delayed until it is bound - and pointing at a delayed one is an error, +/// not a wait. So a consumer that references both an offered project and an assembly built against it +/// used to lose its builder outright: no error, no files, no signature, which is why Errors alone did +/// not see it. +[] +let ``A consumer of both an offered project and an assembly built against it still checks`` () = + let checker = mkChecker true + + let librarySource = + """ +module Shared + +type Carried = { Value: int } + +let make v = { Value = v } +""" + + // Same source, once as a real assembly for Middle to be built against, and once as a project of the + // graph under that same assembly name, which is the one the consumer offers to take + let libraryDll = compileDll checker "Shared" librarySource [] + + let middleDll = + compileDll + checker + "Middle" + """ +module Middle + +/// Mentions Shared.Carried in its own signature, so unpickling Middle has to resolve "Shared" +let carry (v: int) : Shared.Carried = Shared.make v +""" + [ libraryDll ] + + let library = + projectOptionsNamed checker (Some "Shared") [| writeSource librarySource |] [] [||] + + let _, consumer = + projectOptionsNamed + checker + None + [| writeSource "module Consumer\nlet used = Middle.carry 1\n" |] + [ library ] + [| "-r:" + middleDll |] + + let results = checker.ParseAndCheckProject consumer |> Async.RunSynchronously + + Assert.Empty(results.Diagnostics |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error)) + + // The builder failing leaves no error behind, so the signature is what says it ran at all + Assert.NotEmpty(results.AssemblySignature.Entities) + Assert.NotEmpty(results.ProjectContext.GetReferencedAssemblies()) From e80d1afe6a7c0c7ee33100cb44455b37d0c11b6d Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 2 Sep 2026 14:04:54 +0200 Subject: [PATCH 2/3] Release notes --- docs/release-notes/.FSharp.Compiler.Service/11.0.100.md | 1 + 1 file changed, 1 insertion(+) 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 ed1e382d6c7..87ce36ff63c 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -185,6 +185,7 @@ * IL: cache C# extension methods per CCU ([PR #20256](https://github.com/dotnet/fsharp/pull/20256)) * Nullness warning FS3261 on dotted method or property access (e.g. `x.Member`) now underlines the receiver expression and includes the member name and (when known) the binding name in the message. ([Issue #19658](https://github.com/dotnet/fsharp/issues/19658), [PR #19814](https://github.com/dotnet/fsharp/pull/19814)) * Import: share assembly CCUs between projects ([PR #20296](https://github.com/dotnet/fsharp/pull/20296)) +* Import: share a referenced project's CCU instead of pickling it ([PR #20416](https://github.com/dotnet/fsharp/pull/20416)) * IL: share the pickled references ([PR #20301](https://github.com/dotnet/fsharp/pull/20301)) * Direct delegate construction ([PR ##19993](https://github.com/dotnet/fsharp/pull/19993)) * IL: add `ILPreNamespace`, make `ILPreTypeDef` creation lazy ([PR #20092](https://github.com/dotnet/fsharp/pull/20092)) From 552a152bbcb7d50c94c3d9d97b49200affc94eb9 Mon Sep 17 00:00:00 2001 From: Eugene Auduchinok Date: Wed, 9 Sep 2026 18:24:59 +0200 Subject: [PATCH 3/3] Review fixes --- src/Compiler/Driver/CompilerImports.fs | 4 + src/Compiler/Service/IncrementalBuild.fs | 18 +- src/Compiler/Service/TransparentCompiler.fs | 2 +- src/Compiler/TypedTree/TcGlobals.fs | 5 +- src/Compiler/TypedTree/TcGlobals.fsi | 6 +- src/Compiler/TypedTree/TypedTreeOps.Remap.fs | 27 ++- .../TypedTree/TypedTreeOps.Remapping.fs | 19 ++ .../ProjectReferenceHandoverTests.fs | 165 +++++++++++++++++- 8 files changed, 221 insertions(+), 25 deletions(-) diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs index 9ae74ee18b1..077afba145c 100644 --- a/src/Compiler/Driver/CompilerImports.fs +++ b/src/Compiler/Driver/CompilerImports.fs @@ -2632,6 +2632,10 @@ and [] TcImports for aref in data.ILAssemblyRefs do names.Add aref.Name + match data with + | :? IImportedProjectCcu as projectCcu -> names.AddRange projectCcu.ReferencedCcuNames + | _ -> () + let mutable multiModule = false match data.TryGetILModuleDef() |> Option.bind (fun ilModule -> ilModule.Manifest) with diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index b156442491f..6c6afdd6b67 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -563,7 +563,7 @@ type FrameworkImportsCache(size) = // for each cached project. So here we create a new tcGlobals, with the existing framework values // and updated realsig and langversion let tcGlobals = - tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode) + tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode, tcConfig.checkNullness) return tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolved } @@ -649,23 +649,26 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals: TcGlobal let bindTree (readerTcGlobals: TcGlobals) (resolve: string -> CcuThunk option) = let boundTo = Dictionary(StringComparer.OrdinalIgnoreCase) + let viewedCcu = CcuThunk.CreateDelayed assemblyName + // The thunk may still be delayed, so the reference is taken rather than fixed up. A name the - // reader does not have keeps ours: it has no second copy to disagree with. + // reader does not have stays unresolved, as u_ccuref leaves it, so that using it is an error. let ccuRebind = Some(fun (ccu: CcuThunk) -> + // Anonymous record types name the checking ccu, of which generatedCcu is a clone + if String.Equals(ccu.AssemblyName, assemblyName, StringComparison.OrdinalIgnoreCase) then viewedCcu else + match boundTo.TryGetValue ccu.AssemblyName with | true, (already, _) -> already | _ -> let entry = match resolve ccu.AssemblyName with | Some readers -> readers, true - | None -> ccu, false + | None -> CcuThunk.CreateDelayed ccu.AssemblyName, false boundTo[ccu.AssemblyName] <- entry fst entry) - let viewedCcu = CcuThunk.CreateDelayed assemblyName - let ilScopeRef = ILScopeRef.Assembly ilAssemRef let remapping = @@ -757,8 +760,9 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals: TcGlobal && List.forall2 (fun (n1: string, c1: CcuThunk, r1) (n2: string, c2: CcuThunk, r2) -> String.Equals(n1, n2, StringComparison.OrdinalIgnoreCase) - && obj.ReferenceEquals(c1, c2) - && r1 = r2) + && r1 = r2 + // An unresolved name gets a thunk of its own per copy + && (not r1 || obj.ReferenceEquals(c1, c2))) other bindings diff --git a/src/Compiler/Service/TransparentCompiler.fs b/src/Compiler/Service/TransparentCompiler.fs index 99c068b2c31..284244454be 100644 --- a/src/Compiler/Service/TransparentCompiler.fs +++ b/src/Compiler/Service/TransparentCompiler.fs @@ -968,7 +968,7 @@ type internal TransparentCompiler // for each cached project. So here we create a new tcGlobals, with the existing framework values // and updated realsig and langversion let tcGlobals = - tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode) + tcGlobals.WithLanguageSettings(tcConfig.langVersion, tcConfig.realsig, tcConfig.compilationMode, tcConfig.checkNullness) // Note we are not calling diagnosticsLogger.GetDiagnostics() anywhere for this task. // This is ok because not much can actually go wrong here. diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index f46fa81668a..5050e122961 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -1178,11 +1178,12 @@ type TcGlobals( member _.realsig = realsig - member g.WithLanguageSettings(newLangVersion, newRealsig, newCompilationMode) = + member g.WithLanguageSettings(newLangVersion, newRealsig, newCompilationMode, newCheckNullness) = if newLangVersion = langVersion && newRealsig = realsig && newCompilationMode = compilationMode + && newCheckNullness = checkNullness then g else @@ -1193,7 +1194,7 @@ type TcGlobals( fslibCcu, directoryToResolveRelativePaths, isInteractive, - checkNullness, + newCheckNullness, useReflectionFreeCodeGen, tryFindSysTypeCcuHelper, emitDebugInfoInQuotations, diff --git a/src/Compiler/TypedTree/TcGlobals.fsi b/src/Compiler/TypedTree/TcGlobals.fsi index f07ec4a53a1..8b76e469064 100644 --- a/src/Compiler/TypedTree/TcGlobals.fsi +++ b/src/Compiler/TypedTree/TcGlobals.fsi @@ -158,7 +158,11 @@ type internal TcGlobals = /// The same framework import at another project's language settings; every entity is shared. member WithLanguageSettings: - newLangVersion: Features.LanguageVersion * newRealsig: bool * newCompilationMode: CompilationMode -> TcGlobals + newLangVersion: Features.LanguageVersion * + newRealsig: bool * + newCompilationMode: CompilationMode * + newCheckNullness: bool -> + TcGlobals member directoryToResolveRelativePaths: string diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remap.fs b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs index 6970933f64f..826b0b06492 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remap.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Remap.fs @@ -250,13 +250,13 @@ module internal TypeRemapping = TType_ucase(UnionCaseRef(remapOrRebindTyconRef tyenv tcref, n), remapTypesAux tyenv tinst) | TType_anon(anonInfo, l) as ty -> - let tupInfoR = remapTupInfoAux tyenv anonInfo.TupInfo + let anonInfoR = remapAnonInfoAux tyenv anonInfo let lR = remapTypesAux tyenv l - if anonInfo.TupInfo === tupInfoR && l === lR then + if anonInfo === anonInfoR && l === lR then ty else - TType_anon(AnonRecdTypeInfo.Create(anonInfo.Assembly, tupInfoR, anonInfo.SortedIds), lR) + TType_anon(anonInfoR, lR) | TType_tuple(tupInfo, l) as ty -> let tupInfoR = remapTupInfoAux tyenv tupInfo @@ -314,6 +314,19 @@ module internal TypeRemapping = | Some(TType_measure unt) -> remapMeasureAux tyenv unt | Some ty -> failwithf "incorrect kinds: %A" ty + and remapAnonInfoAux tyenv (anonInfo: AnonRecdTypeInfo) = + let tupInfoR = remapTupInfoAux tyenv anonInfo.TupInfo + + let ccuR = + match tyenv.ccuRebind with + | Some rebind -> rebind anonInfo.Assembly + | None -> anonInfo.Assembly + + if anonInfo.TupInfo === tupInfoR && obj.ReferenceEquals(ccuR, anonInfo.Assembly) then + anonInfo + else + AnonRecdTypeInfo.Create(ccuR, tupInfoR, anonInfo.SortedIds) + and remapTupInfoAux _tyenv unt = match unt with | TupInfo.Const _ -> unt @@ -366,7 +379,8 @@ module internal TypeRemapping = ) | FSRecdFieldSln(tinst, rfref, isSet) -> FSRecdFieldSln(remapTypesAux tyenv tinst, remapRecdFieldRef tyenv.tyconRefRemap rfref, isSet) - | FSAnonRecdFieldSln(anonInfo, tinst, n) -> FSAnonRecdFieldSln(anonInfo, remapTypesAux tyenv tinst, n) + | FSAnonRecdFieldSln(anonInfo, tinst, n) -> + FSAnonRecdFieldSln(remapAnonInfoAux tyenv anonInfo, remapTypesAux tyenv tinst, n) | BuiltInSln -> BuiltInSln | ClosedExprSln e -> ClosedExprSln e // no need to remap because it is a closed expression, referring only to external types @@ -386,7 +400,10 @@ module internal TypeRemapping = // in the same way as types let newSlnCell = ref slnCell - TTrait(tysR, nm, flags, argTysR, retTyR, source, newSlnCell, traitCtxt) + // u_trait reads none: the producer's context would keep a reader's own extension members out + let traitCtxtR = if tyenv.ccuRebind.IsSome then None else traitCtxt + + TTrait(tysR, nm, flags, argTysR, retTyR, source, newSlnCell, traitCtxtR) and bindTypars tps tyargs tpinst = match tps with diff --git a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs index 56f744d94a7..e58984a0b1c 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.Remapping.fs @@ -2233,6 +2233,25 @@ module internal ExprRemapping = | TMeasureableRepr x -> TMeasureableRepr(remapType tmenv x) and remapTyconAug tmenv (x: TyconAugmentation) = + let x = + match tmenv.ccuRebind with + | None -> x + | Some _ -> + // As p_tcaug: an explicit interface implementation relinks by name and type in the reader, + // and can land on a default member of the same name + let kept = + x.AdhocMembers |> List.filter (fun (isExplicitImpl, _) -> not isExplicitImpl) + + let keptList: ResizeArray | null = + match kept with + | [] -> null + | _ -> ResizeArray kept + + { x with + tcaug_adhoc = NameMultiMap.ofList [ for _, vref in kept -> vref.LogicalName, vref ] + tcaug_adhoc_list = keptList + } + { x with tcaug_equals = x.tcaug_equals |> Option.map (mapPair (remapValRef tmenv, remapValRef tmenv)) tcaug_compare = x.tcaug_compare |> Option.map (mapPair (remapValRef tmenv, remapValRef tmenv)) diff --git a/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs b/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs index d51987c8acf..5972f304bb2 100644 --- a/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs @@ -79,13 +79,16 @@ let private ccuOf (assembly: FSharpAssembly) = | :? CcuThunk as ccu -> Some ccu.Contents | _ -> None) -/// The ccu the given project ended up with for one of its references -let private referencedCcu (checker: FSharpChecker) (options: FSharpProjectOptions) name = +/// One of the given project's references, as the project sees it +let private referencedAssembly (checker: FSharpChecker) (options: FSharpProjectOptions) name = let results = checker.ParseAndCheckProject options |> Async.RunSynchronously results.ProjectContext.GetReferencedAssemblies() |> List.find (fun assembly -> assembly.SimpleName = name) - |> ccuOf + +/// The ccu the given project ended up with for one of its references +let private referencedCcu checker options name = + referencedAssembly checker options name |> ccuOf let private errorsIn (checker: FSharpChecker) (options: FSharpProjectOptions) = let results = checker.ParseAndCheckProject options |> Async.RunSynchronously @@ -98,6 +101,7 @@ let private librarySource = module Library let publicValue = 1 +let anonymous = {| Value = 1 |} let internal secretValue = 2 type internal SecretType = { S: int } type Colour = internal Red | Green @@ -479,12 +483,8 @@ let private describeSymbol (s: FSharpSymbol) = @ attribsOfSymbol s) /// Everything a host can see of a referenced project, however this build of it arrived -let private referencedSurface (checker: FSharpChecker) (options: FSharpProjectOptions) name = - let results = checker.ParseAndCheckProject options |> Async.RunSynchronously - - let assembly = - results.ProjectContext.GetReferencedAssemblies() - |> List.find (fun a -> a.SimpleName = name) +let private referencedSurface checker options name = + let assembly = referencedAssembly checker options name allSymbolsInEntities true assembly.Contents.Entities |> List.map describeSymbol @@ -655,3 +655,150 @@ let carry (v: int) : Shared.Carried = Shared.make v // The builder failing leaves no error behind, so the signature is what says it ran at all Assert.NotEmpty(results.AssemblySignature.Entities) Assert.NotEmpty(results.ProjectContext.GetReferencedAssemblies()) + +[] +let ``A project sharing the framework import does not inherit nullness checking`` () = + let checker = mkChecker true + + let _, warm = + projectOptions checker "module Warm\nlet x = 1\n" [] [| "--langversion:8.0"; "--checknulls+" |] + + Assert.Empty(errorsIn checker warm) + + let _, target = + projectOptions + checker + "module Target\nlet x: string = null\n" + [] + [| "--langversion:9.0"; "--checknulls-"; "--warnaserror:3261" |] + + Assert.Empty(errorsIn checker target) + +[] +let ``An assembly built against a taken project is not shared across bindings of it`` () = + let checker = mkChecker true + + let dependencySource = "module Dependency\ntype Marker = Marker\n" + let sharedSource = "module Shared\ntype Carried = { Value: Dependency.Marker option }\n" + + let dependencyDll = compileDll checker "Dependency" dependencySource [] + let sharedDll = compileDll checker "Shared" sharedSource [ dependencyDll ] + + let middleDll = + compileDll checker "Middle" "module Middle\nlet carry (x: Shared.Carried) = x\n" [ sharedDll; dependencyDll ] + + let dependencyProject () = + projectOptionsNamed checker (Some "Dependency") [| writeSource dependencySource |] [] [||] + + let first = dependencyProject () + let second = dependencyProject () + + let shared = + projectOptionsNamed checker (Some "Shared") [| writeSource sharedSource |] [ first ] [||] + + let consumerWith dependency = + projectOptionsNamed + checker + None + [| writeSource "module Consumer\nlet x: Shared.Carried = Middle.carry { Value = None }\n" |] + [ shared; dependency ] + [| "-r:" + middleDll |] + |> snd + + Assert.Empty(errorsIn checker (consumerWith first)) + Assert.Empty(errorsIn checker (consumerWith second)) + +[] +let ``A consumer's extension members solve a handed-over member constraint`` () = + let librarySource = + "module Library\nlet inline negate (x: ^T) = (^T : (static member Negate: ^T -> ^T) x)\n" + + let consumerSource = + "module Consumer\ntype System.Int32 with\n static member Negate(x: int) = -x\nlet value = Library.negate 42\n" + + let errorsWith share = + let checker = mkChecker share + let library = projectOptions checker librarySource [] [||] + let _, consumer = projectOptions checker consumerSource [ library ] [||] + errorsIn checker consumer + + Assert.Empty(errorsWith false) + Assert.Empty(errorsWith true) + +[] +let ``A type from an assembly the consumer does not reference is still an error`` () = + let errorsWith share = + let checker = mkChecker share + let leaf = projectOptions checker "module Leaf\ntype Carried = { Value: int }\n" [] [||] + + let middle = + projectOptions checker "module Middle\nlet make () : Leaf.Carried = { Value = 1 }\n" [ leaf ] [||] + + let _, consumer = + projectOptions checker "module Consumer\nlet value = (Middle.make()).Value\n" [ middle ] [||] + + errorsIn checker consumer + |> Array.map (fun d -> d.ErrorNumber) + |> Array.distinct + |> Array.sort + |> List.ofArray + + let unpickled = errorsWith false + Assert.True(List.contains 74 unpickled, sprintf "%A" unpickled) + Assert.Equal(unpickled, errorsWith true) + +[] +let ``A handed-over anonymous record type is owned by the referenced assembly`` () = + let ownerWith share = + let checker = mkChecker share + let dll, libraryOptions = projectOptions checker "module Library\nlet record = {| Value = 1 |}\n" [] [||] + + let _, consumer = + projectOptions checker (consumerOf "let record = Library.record") [ dll, libraryOptions ] [||] + + Assert.Empty(errorsIn checker consumer) + + let library = + (referencedAssembly checker consumer (Path.GetFileNameWithoutExtension dll)).Contents.FindEntityByPath [ "Library" ] + + let record = library.Value.MembersFunctionsAndValues |> Seq.find (fun v -> v.LogicalName = "record") + record.FullType.AnonRecordTypeDetails.Assembly.FileName = Some dll + + Assert.True(ownerWith false) + Assert.True(ownerWith true) + +[] +let ``A handed-over type does not list its explicit interface implementations`` () = + let librarySource = + """ +module Library + +type IFoo = + abstract M: unit -> int + +type C() = + abstract M: unit -> int + default _.M() = 2 + + interface IFoo with + member _.M() = 1 +""" + + let membersWith share = + let checker = mkChecker share + let library = projectOptions checker librarySource [] [||] + let libraryName = Path.GetFileNameWithoutExtension(fst library) + let _, consumer = projectOptions checker (consumerOf "let c = Library.C()") [ library ] [||] + Assert.Empty(errorsIn checker consumer) + + let c = + (referencedAssembly checker consumer libraryName).Contents.FindEntityByPath [ "Library"; "C" ] + + c.Value.MembersFunctionsAndValues + |> Seq.filter (fun m -> m.LogicalName = "M" && not m.IsDispatchSlot) + |> Seq.map (fun m -> m.DisplayName, m.IsExplicitInterfaceImplementation) + |> Seq.toArray + + let unpickled = membersWith false + Assert.Equal<(string * bool)[]>([| "M", false |], unpickled) + Assert.Equal<(string * bool)[]>(unpickled, membersWith true)