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)) 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..077afba145c 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() @@ -2544,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 @@ -2568,54 +2660,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 +2733,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 +2756,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 +2791,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 +2836,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..6c6afdd6b67 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, tcConfig.checkNullness) return tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolved } @@ -633,13 +615,103 @@ 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) + + 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 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 -> CcuThunk.CreateDelayed ccu.AssemblyName, false + + boundTo[ccu.AssemblyName] <- entry + fst entry) + + 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 +731,60 @@ 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) + && r1 = r2 + // An unresolved name gets a thunk of its own per copy + && (not r1 || obj.ReferenceEquals(c1, c2))) + 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 +987,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..284244454be 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, tcConfig.checkNullness) // 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..5050e122961 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -1178,6 +1178,34 @@ type TcGlobals( member _.realsig = realsig + member g.WithLanguageSettings(newLangVersion, newRealsig, newCompilationMode, newCheckNullness) = + if + newLangVersion = langVersion + && newRealsig = realsig + && newCompilationMode = compilationMode + && newCheckNullness = checkNullness + then + g + else + let copy = + TcGlobals( + compilingFSharpCore, + ilg, + fslibCcu, + directoryToResolveRelativePaths, + isInteractive, + newCheckNullness, + 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..8b76e469064 100644 --- a/src/Compiler/TypedTree/TcGlobals.fsi +++ b/src/Compiler/TypedTree/TcGlobals.fsi @@ -156,6 +156,14 @@ 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 * + newCheckNullness: bool -> + 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..826b0b06492 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,30 +223,40 @@ 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 + 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 @@ -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) @@ -269,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 @@ -321,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 @@ -341,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 @@ -389,7 +451,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 +526,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..e58984a0b1c 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 + + /// 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 mkRemapContext g stackGuard = { g = g; stackGuard = stackGuard } + 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)) } @@ -2184,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)) @@ -2205,7 +2273,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 +2297,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 +2457,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 +2509,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..5972f304bb2 --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/ProjectReferenceHandoverTests.fs @@ -0,0 +1,804 @@ +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) + +/// 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) + +/// 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 + + results.Diagnostics + |> Array.filter (fun d -> d.Severity = FSharpDiagnosticSeverity.Error) + +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 +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 options name = + let assembly = referencedAssembly checker options 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()) + +[] +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)