From b89d98e692cd3caac0b8cd29529c90e60304d830 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 9 Feb 2017 20:22:39 +0000 Subject: [PATCH] Make concurrency assumptions more explicit via token passing (#2371) * tame concurrency draft * tame-conc * fix tests * fix build --- FSharp.sln | 28 +- src/absil/il.fs | 18 +- src/absil/illib.fs | 82 +++- src/absil/ilread.fs | 13 +- src/absil/ilread.fsi | 1 + src/absil/ilreflect.fs | 8 +- src/fsharp/CompileOps.fs | 354 ++++++++------- src/fsharp/CompileOps.fsi | 51 ++- src/fsharp/CompileOptions.fs | 10 +- src/fsharp/CompileOptions.fsi | 5 +- src/fsharp/ErrorLogger.fs | 6 + src/fsharp/ExtensionTyping.fsi | 1 + src/fsharp/IlxGen.fs | 2 +- src/fsharp/InternalCollections.fs | 94 ++-- src/fsharp/InternalCollections.fsi | 63 +-- src/fsharp/MSBuildReferenceResolver.fs | 2 +- src/fsharp/QuotationTranslator.fs | 7 +- src/fsharp/TypeChecker.fs | 9 +- src/fsharp/ast.fs | 25 +- src/fsharp/fsc.fs | 98 ++-- src/fsharp/fsc.fsi | 1 + src/fsharp/fsi/fsi.fs | 211 +++++---- src/fsharp/import.fs | 27 +- src/fsharp/import.fsi | 5 +- src/fsharp/lexhelp.fs | 4 +- src/fsharp/lexhelp.fsi | 1 + src/fsharp/tast.fs | 8 +- src/fsharp/vs/IncrementalBuild.fs | 351 +++++++------- src/fsharp/vs/IncrementalBuild.fsi | 42 +- src/fsharp/vs/Reactor.fs | 25 +- src/fsharp/vs/Reactor.fsi | 12 +- src/fsharp/vs/ServiceDeclarations.fs | 3 +- src/fsharp/vs/ServiceLexing.fs | 4 +- src/fsharp/vs/ServiceUntypedParse.fs | 6 +- src/fsharp/vs/service.fs | 427 ++++++++++-------- src/fsharp/vs/service.fsi | 5 +- src/ilx/ilxsettings.fs | 4 +- tests/scripts/compiler-perf-results.txt | 4 +- .../XmlDocumentation.fs | 11 +- .../Salsa/FSharpLanguageServiceTestable.fs | 2 +- .../unittests/Tests.InternalCollections.fs | 15 +- .../Tests.LanguageService.IncrementalBuild.fs | 117 ++--- 42 files changed, 1204 insertions(+), 958 deletions(-) diff --git a/FSharp.sln b/FSharp.sln index be0a325264..3cac84673c 100644 --- a/FSharp.sln +++ b/FSharp.sln @@ -43,7 +43,7 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "HostedCompilerServer", "tes EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "ILComparer", "tests\fsharpqa\testenv\src\ILComparer\ILComparer.fsproj", "{2E60864A-E3FF-4BCC-810F-DC7C34E6B236}" EndProject -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Tests.FSharpSuite.DrivingCoreCLR", "tests\fsharp\FSharp.Tests.FSharpSuite.DrivingCoreCLR.fsproj", "{BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}" +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.LanguageService.Compiler", "src\fsharp\FSharp.LanguageService.Compiler\FSharp.LanguageService.Compiler.fsproj", "{A437A6EC-5323-47C2-8F86-E2CAC54FF152}" EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution @@ -206,18 +206,18 @@ Global {2E60864A-E3FF-4BCC-810F-DC7C34E6B236}.Release|Any CPU.Build.0 = Release|Any CPU {2E60864A-E3FF-4BCC-810F-DC7C34E6B236}.Release|x86.ActiveCfg = Release|Any CPU {2E60864A-E3FF-4BCC-810F-DC7C34E6B236}.Release|x86.Build.0 = Release|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Debug|Any CPU.Build.0 = Debug|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Debug|x86.ActiveCfg = Debug|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Debug|x86.Build.0 = Debug|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Proto|Any CPU.ActiveCfg = Proto|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Proto|Any CPU.Build.0 = Proto|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Proto|x86.ActiveCfg = Proto|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Proto|x86.Build.0 = Proto|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Release|Any CPU.ActiveCfg = Release|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Release|Any CPU.Build.0 = Release|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Release|x86.ActiveCfg = Release|Any CPU - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED}.Release|x86.Build.0 = Release|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Debug|Any CPU.Build.0 = Debug|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Debug|x86.ActiveCfg = Debug|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Debug|x86.Build.0 = Debug|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Proto|Any CPU.ActiveCfg = Proto|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Proto|Any CPU.Build.0 = Proto|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Proto|x86.ActiveCfg = Proto|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Proto|x86.Build.0 = Proto|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Release|Any CPU.ActiveCfg = Release|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Release|Any CPU.Build.0 = Release|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Release|x86.ActiveCfg = Release|Any CPU + {A437A6EC-5323-47C2-8F86-E2CAC54FF152}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -236,6 +236,6 @@ Global {88E2D422-6852-46E3-A740-83E391DC7973} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} {4239EFEA-E746-446A-BF7A-51FCBAB13946} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} {2E60864A-E3FF-4BCC-810F-DC7C34E6B236} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} - {BDA4D411-6AD9-4B3E-A3B3-07BAD6BEF1ED} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} + {A437A6EC-5323-47C2-8F86-E2CAC54FF152} = {3881429D-A97A-49EB-B7AE-A82BA5FE9C77} EndGlobalSection EndGlobal diff --git a/src/absil/il.fs b/src/absil/il.fs index 06cc214729..fe35c6b069 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -80,10 +80,10 @@ let rec splitNamespaceAux (nm:string) = s1::splitNamespaceAux s2 /// Global State. All namespace splits ever seen -// ++GLOBAL MUTABLE STATE +// ++GLOBAL MUTABLE STATE (concurrency-safe) let memoizeNamespaceTable = new ConcurrentDictionary() -// ++GLOBAL MUTABLE STATE +// ++GLOBAL MUTABLE STATE (concurrency-safe) let memoizeNamespaceRightTable = new ConcurrentDictionary() @@ -92,7 +92,7 @@ let splitNamespace nm = let splitNamespaceMemoized nm = splitNamespace nm -// ++GLOBAL MUTABLE STATE +// ++GLOBAL MUTABLE STATE (concurrency-safe) let memoizeNamespaceArrayTable = Concurrent.ConcurrentDictionary() @@ -1865,15 +1865,9 @@ let andTailness x y = let formatCodeLabel (x:int) = "L"+string x -let new_generator () = - let i = ref 0 - fun _n -> - incr i; !i - -// ++GLOBAL MUTABLE STATE -let codeLabelGenerator = (new_generator () : unit -> ILCodeLabel) -let generateCodeLabel x = codeLabelGenerator x - +// ++GLOBAL MUTABLE STATE (concurrency safe) +let codeLabelCount = ref 0 +let generateCodeLabel() = System.Threading.Interlocked.Increment(codeLabelCount) let instrIsRet i = match i with diff --git a/src/absil/illib.fs b/src/absil/illib.fs index e8ed13cdf3..a1fc995761 100644 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -448,6 +448,46 @@ module Dictionary = module Lazy = let force (x: Lazy<'T>) = x.Force() +//---------------------------------------------------------------------------- +// Singe threaded execution and mutual exclusion + +/// Represents a permission active at this point in execution +type ExecutionToken = interface end + +/// Represents a token that indicates execution on the compilation thread, i.e. +/// - we have full access to the (partially mutable) TAST and TcImports data structures +/// - compiler execution may result in type provider invocations when resolving types and members +/// - we can access various caches in the SourceCodeServices +/// +/// Like other execution tokens this should be passed via argument passing and not captured/stored beyond +/// the lifetime of stack-based calls. This is not checked, it is a discipline withinn the compiler code. +type CompilationThreadToken() = interface ExecutionToken + +/// Represnts a place where we are stating that execution on the compilation thread is required. The +/// reason why will be documented in a comment in the code at the callsite. +let RequireCompilationThread (_ctok: CompilationThreadToken) = () + +/// Represnts a place in the compiler codebase where we are passed a CompilationThreadToken unnecessarily. +/// This reprents code that may potentially not need to be executed on the compilation thread. +let DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent (_ctok: CompilationThreadToken) = () + +/// Represnts a place in the compiler codebase where we assume we are executing on a compilation thread +let AssumeCompilationThreadWithoutEvidence () = Unchecked.defaultof + +/// Represents a token that indicates execution on a any of several potential user threads calling the F# compiler services. +type AnyCallerThreadToken() = interface ExecutionToken +let AssumeAnyCallerThreadWithoutEvidence () = Unchecked.defaultof + +/// A base type for various types of tokens that must be passed when a lock is taken. +/// Each different static lock should declare a new subtype of this type. +type LockToken = inherit ExecutionToken +let AssumeLockWithoutEvidence<'LockTokenType when 'LockTokenType :> LockToken> () = Unchecked.defaultof<'LockTokenType> + +/// Encapsulates a lock associated with a particular token-type representing the acquisition of that lock. +type Lock<'LockTokenType when 'LockTokenType :> LockToken>() = + let lockObj = obj() + member __.AcquireLock f = lock lockObj (fun () -> f (AssumeLockWithoutEvidence<'LockTokenType>())) + //--------------------------------------------------- // Misc @@ -495,7 +535,7 @@ module ResultOrException = /// Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled type Eventually<'T> = | Done of 'T - | NotYetDone of (unit -> Eventually<'T>) + | NotYetDone of (CompilationThreadToken -> Eventually<'T>) [] module Eventually = @@ -504,42 +544,42 @@ module Eventually = let rec box e = match e with | Done x -> Done (Operators.box x) - | NotYetDone (work) -> NotYetDone (fun () -> box (work())) + | NotYetDone (work) -> NotYetDone (fun ctok -> box (work ctok)) - let rec forceWhile check e = + let rec forceWhile ctok check e = match e with | Done x -> Some(x) | NotYetDone (work) -> if not(check()) then None - else forceWhile check (work()) + else forceWhile ctok check (work ctok) - let force e = Option.get (forceWhile (fun () -> true) e) + let force ctok e = Option.get (forceWhile ctok (fun () -> true) e) /// Keep running the computation bit by bit until a time limit is reached. /// The runner gets called each time the computation is restarted let repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled timeShareInMilliseconds (ct: CancellationToken) runner e = let sw = new System.Diagnostics.Stopwatch() - let rec runTimeShare e = - runner (fun () -> + let rec runTimeShare ctok e = + runner ctok (fun ctok -> sw.Reset() sw.Start(); - let rec loop(e) = - match e with - | Done _ -> e + let rec loop ctok ev2 = + match ev2 with + | Done _ -> ev2 | NotYetDone work -> if ct.IsCancellationRequested || sw.ElapsedMilliseconds > timeShareInMilliseconds then sw.Stop(); - NotYetDone(fun () -> runTimeShare e) + NotYetDone(fun ctok -> runTimeShare ctok ev2) else - loop(work()) - loop(e)) - runTimeShare e + loop ctok (work ctok) + loop ctok e) + NotYetDone (fun ctok -> runTimeShare ctok e) /// Keep running the asynchronous computation bit by bit. The runner gets called each time the computation is restarted. /// Can be cancelled in the normal way. - let forceAsync (runner: (unit -> Eventually<'T>) -> Async>) (e: Eventually<'T>) : Async<'T option> = + let forceAsync (runner: (CompilationThreadToken -> Eventually<'T>) -> Async>) (e: Eventually<'T>) : Async<'T option> = let rec loop (e: Eventually<'T>) = async { match e with @@ -553,7 +593,7 @@ module Eventually = let rec bind k e = match e with | Done x -> k x - | NotYetDone work -> NotYetDone (fun () -> bind k (work())) + | NotYetDone work -> NotYetDone (fun ctok -> bind k (work ctok)) let fold f acc seq = (Done acc,seq) ||> Seq.fold (fun acc x -> acc |> bind (fun acc -> f acc x)) @@ -562,13 +602,13 @@ module Eventually = match e with | Done x -> Done(Result x) | NotYetDone work -> - NotYetDone (fun () -> - let res = try Result(work()) with | e -> Exception e + NotYetDone (fun ctok -> + let res = try Result(work ctok) with | e -> Exception e match res with | Result cont -> catch cont | Exception e -> Done(Exception e)) - let delay f = NotYetDone (fun () -> f()) + let delay (f: unit -> Eventually<'T>) = NotYetDone (fun _ctok -> f()) let tryFinally e compensation = catch (e) @@ -581,6 +621,10 @@ module Eventually = catch e |> bind (function Result v -> Done v | Exception e -> handler e) + // All eventually computations carry a CompiationThreadToken + let token = + NotYetDone (fun ctok -> Done ctok) + type EventuallyBuilder() = member x.Bind(e,k) = Eventually.bind k e member x.Return(v) = Eventually.Done v diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index bd82b9401d..eeaa4e6ab5 100644 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -14,6 +14,7 @@ open System.IO open System.Runtime.InteropServices open System.Collections.Generic open Internal.Utilities +open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal #if !FX_NO_PDB_READER @@ -3964,10 +3965,10 @@ let OpenILModuleReader infile opts = dispose = (fun () -> ClosePdbReader pdb) } -// ++GLOBAL MUTABLE STATE -let ilModuleReaderCache = - new Internal.Utilities.Collections.AgedLookup<(string * System.DateTime),ILModuleReader>(0, areSame=(fun (x,y) -> x = y)) - +// ++GLOBAL MUTABLE STATE (concurrency safe via locking) +type ILModuleReaderCacheLockToken() = interface LockToken +let ilModuleReaderCache = new AgedLookup(0, areSame=(fun (x,y) -> x = y)) +let ilModuleReaderCacheLock = Lock() let OpenILModuleReaderAfterReadingAllBytes infile opts = // Pseudo-normalize the paths. @@ -3979,7 +3980,7 @@ let OpenILModuleReaderAfterReadingAllBytes infile opts = let cacheResult = if not succeeded then None // Fall back to uncached. else if opts.pdbPath.IsSome then None // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable - else ilModuleReaderCache.TryGet(key) + else ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.TryGet(ltok, key)) match cacheResult with | Some(ilModuleReader) -> ilModuleReader | None -> @@ -3990,7 +3991,7 @@ let OpenILModuleReaderAfterReadingAllBytes infile opts = ilAssemblyRefs = ilAssemblyRefs dispose = (fun () -> ClosePdbReader pdb) } if Option.isNone pdb && succeeded then - ilModuleReaderCache.Put(key, ilModuleReader) + ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.Put(ltok, key, ilModuleReader)) ilModuleReader let OpenILModuleReaderFromBytes fileNameForDebugOutput bytes opts = diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi index ccc4c72185..2b0774d0cd 100644 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -30,6 +30,7 @@ open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.ErrorLogger open System.IO diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs index 5a4772148d..5f87167dca 100644 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -336,7 +336,7 @@ type cenv = { ilg: ILGlobals tryFindSysILTypeRef : string -> ILTypeRef option generatePdb: bool - resolvePath: (ILAssemblyRef -> Choice option) } + resolveAssemblyRef: (ILAssemblyRef -> Choice option) } /// Convert an Abstract IL type reference to Reflection.Emit System.Type value. // This ought to be an adequate substitute for this whole function, but it needs @@ -350,7 +350,7 @@ let convTypeRefAux (cenv:cenv) (tref:ILTypeRef) = match tref.Scope with | ILScopeRef.Assembly asmref -> let assembly = - match cenv.resolvePath asmref with + match cenv.resolveAssemblyRef asmref with | Some (Choice1Of2 path) -> FileSystem.AssemblyLoadFrom(path) | Some (Choice2Of2 assembly) -> @@ -2003,8 +2003,8 @@ let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo, collectible) let modB = asmB.DefineDynamicModuleAndLog(assemblyName,filename,debugInfo) asmB,modB -let emitModuleFragment (ilg, emEnv, asmB : AssemblyBuilder, modB : ModuleBuilder, modul : IL.ILModuleDef, debugInfo : bool, resolvePath, tryFindSysILTypeRef) = - let cenv = { ilg = ilg ; generatePdb = debugInfo; resolvePath=resolvePath; tryFindSysILTypeRef=tryFindSysILTypeRef } +let emitModuleFragment (ilg, emEnv, asmB : AssemblyBuilder, modB : ModuleBuilder, modul : IL.ILModuleDef, debugInfo : bool, resolveAssemblyRef, tryFindSysILTypeRef) = + let cenv = { ilg = ilg ; generatePdb = debugInfo; resolveAssemblyRef=resolveAssemblyRef; tryFindSysILTypeRef=tryFindSysILTypeRef } let emEnv = buildModuleFragment cenv emEnv asmB modB modul match modul.Manifest with diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index c7ffa99baf..31de27365d 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -2276,13 +2276,13 @@ type TcConfigBuilder = shadowCopyReferences = false } - member tcConfigB.ResolveSourceFile(m,nm,pathLoadedFrom) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + member tcConfigB.ResolveSourceFile(m, nm, pathLoadedFrom) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter ResolveFileUsingPaths(tcConfigB.includes @ [pathLoadedFrom],m,nm) /// Decide names of output file, pdb and assembly - member tcConfigB.DecideNames sourceFiles = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + member tcConfigB.DecideNames (sourceFiles) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter if sourceFiles = [] then errorR(Error(FSComp.SR.buildNoInputsSpecified(),rangeCmdArgs)) let ext() = match tcConfigB.target with Dll -> ".dll" | Module -> ".netmodule" | ConsoleExe | WinExe -> ".exe" let implFiles = sourceFiles |> List.filter (fun lower -> List.exists (Filename.checkSuffix (String.lowercase lower)) FSharpImplFileSuffixes) @@ -2317,7 +2317,7 @@ type TcConfigBuilder = outfile, pdbfile, assemblyName member tcConfigB.TurnWarningOff(m,s:string) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter match GetWarningNumber(m,s) with | None -> () | Some n -> @@ -2326,7 +2326,7 @@ type TcConfigBuilder = tcConfigB.specificWarnOff <- ListSet.insert (=) n tcConfigB.specificWarnOff member tcConfigB.TurnWarningOn(m, s:string) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter match GetWarningNumber(m,s) with | None -> () | Some n -> @@ -2411,8 +2411,8 @@ let OpenILBinary(filename,optimizeForMemory,openBinariesInMemory,ilGlobalsOpt, p ILBinaryReader.pdbPath = pdbPathOption } // Visual Studio uses OpenILModuleReaderAfterReadingAllBytes for all DLLs to avoid having to dispose of any readers explicitly - if openBinariesInMemory // && not syslib - then ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes filename opts + if openBinariesInMemory then // && not syslib + ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes filename opts else let location = #if FSI_SHADOW_COPY_REFERENCES @@ -2440,7 +2440,9 @@ type AssemblyResolution = ilAssemblyRef : ILAssemblyRef option ref } override this.ToString() = sprintf "%s%s" (if this.sysdir then "[sys]" else "") this.resolvedPath + member this.ProjectReference = this.originalReference.ProjectReference + member this.ILAssemblyRef = match !this.ilAssemblyRef with | Some(assref) -> assref @@ -2749,7 +2751,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = member x.copyFSharpCore = data.copyFSharpCore member x.shadowCopyReferences = data.shadowCopyReferences static member Create(builder,validate) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter TcConfig(builder,validate) member x.referenceResolver = data.referenceResolver @@ -2761,8 +2763,8 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = (sourceFiles |> List.mapi (fun i _ -> (i = n-1)), tcConfig.target.IsExe) // This call can fail if no CLR is found (this is the path to mscorlib) - member tcConfig.TargetFrameworkDirectories = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + member tcConfig.GetTargetFrameworkDirectories() = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter match tcConfig.clrRoot with | Some x -> [tcConfig.MakePathAbsolute x] @@ -2787,14 +2789,14 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = with e -> errorRecovery e range0; [] - member tcConfig.ComputeLightSyntaxInitialStatus filename = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + member tcConfig.ComputeLightSyntaxInitialStatus(filename) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter let lower = String.lowercase filename let lightOnByDefault = List.exists (Filename.checkSuffix lower) FSharpLightSyntaxFileSuffixes if lightOnByDefault then (tcConfig.light <> Some(false)) else (tcConfig.light = Some(true) ) member tcConfig.GetAvailableLoadedSources() = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter let resolveLoadedSource (m,path) = try if not(FileSystem.SafeExists(path)) then @@ -2818,15 +2820,15 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = member tcConfig.IsSystemAssembly (filename:string) = try FileSystem.SafeExists filename && - ((tcConfig.TargetFrameworkDirectories |> List.exists (fun clrRoot -> clrRoot = Path.GetDirectoryName filename)) || + ((tcConfig.GetTargetFrameworkDirectories() |> List.exists (fun clrRoot -> clrRoot = Path.GetDirectoryName filename)) || (systemAssemblies.Contains(fileNameWithoutExtension filename))) with _ -> false // This is not the complete set of search paths, it is just the set // that is special to F# (as compared to MSBuild resolution) - member tcConfig.SearchPathsForLibraryFiles = - [ yield! tcConfig.TargetFrameworkDirectories + member tcConfig.GetSearchPathsForLibraryFiles() = + [ yield! tcConfig.GetTargetFrameworkDirectories() yield! List.map (tcConfig.MakePathAbsolute) tcConfig.includes yield tcConfig.implicitIncludeDir yield tcConfig.fsharpBinariesDir ] @@ -2837,7 +2839,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = member tcConfig.TryResolveLibWithDirectories (r:AssemblyReference) = let m,nm = r.Range, r.Text - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter // Only want to resolve certain extensions (otherwise, 'System.Xml' is ambiguous). // MSBuild resolution is limitted to .exe and .dll so do the same here. let ext = System.IO.Path.GetExtension(nm) @@ -2870,9 +2872,9 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // during some global checks it won't be. We append to the end of the search list so that this is the last // place that is checked. if m <> range0 && m <> rangeStartup && m <> rangeCmdArgs && FileSystem.IsPathRootedShim m.FileName then - tcConfig.SearchPathsForLibraryFiles @ [Path.GetDirectoryName(m.FileName)] + tcConfig.GetSearchPathsForLibraryFiles() @ [Path.GetDirectoryName(m.FileName)] else - tcConfig.SearchPathsForLibraryFiles + tcConfig.GetSearchPathsForLibraryFiles() let resolved = TryResolveFileUsingPaths(searchPaths,m,nm) match resolved with @@ -2897,9 +2899,9 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = | None -> None else None - member tcConfig.ResolveLibWithDirectories ccuLoadFaulureAction (r:AssemblyReference) = + member tcConfig.ResolveLibWithDirectories (ccuLoadFaulureAction, r:AssemblyReference) = let m,nm = r.Range, r.Text - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter // test for both libraries and executables let ext = System.IO.Path.GetExtension(nm) let isExe = (String.Compare(ext,".exe",StringComparison.OrdinalIgnoreCase) = 0) @@ -2912,20 +2914,20 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = else [AssemblyReference(m,nm+".dll",None);AssemblyReference(m,nm+".exe",None);AssemblyReference(m,nm+".netmodule",None)] - match rs |> List.tryPick tcConfig.TryResolveLibWithDirectories with + match rs |> List.tryPick (fun r -> tcConfig.TryResolveLibWithDirectories r) with | Some(res) -> Some res | None -> match ccuLoadFaulureAction with | CcuLoadFailureAction.RaiseError -> - let searchMessage = String.concat "\n " tcConfig.SearchPathsForLibraryFiles + let searchMessage = String.concat "\n " (tcConfig.GetSearchPathsForLibraryFiles()) raise (FileNameNotResolved(nm,searchMessage,m)) | CcuLoadFailureAction.ReturnNone -> None - member tcConfig.ResolveSourceFile(m,nm,pathLoadedFrom) = - data.ResolveSourceFile(m,nm,pathLoadedFrom) + member tcConfig.ResolveSourceFile(m, nm, pathLoadedFrom) = + data.ResolveSourceFile(m, nm, pathLoadedFrom) - member tcConfig.CheckFSharpBinary (filename,ilAssemblyRefs,m) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + member tcConfig.CheckFSharpBinary (filename, ilAssemblyRefs, m) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter checkFSharpBinaryCompatWithMscorlib filename ilAssemblyRefs None m // NOTE!! if mode=Speculative then this method must not report ANY warnings or errors through 'warning' or 'error'. Instead @@ -2933,7 +2935,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = // // NOTE!! if mode=ReportErrors then this method must not raise exceptions. It must just report the errors and recover static member TryResolveLibsUsingMSBuildRules (tcConfig:TcConfig,originalReferences:AssemblyReference list, errorAndWarningRange:range, mode:ResolveAssemblyReferenceMode) : AssemblyResolution list * UnresolvedAssemblyReference list = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter if tcConfig.useSimpleResolution then failwith "MSBuild resolution is not supported." if originalReferences=[] then [],[] @@ -2985,7 +2987,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = let resolvedAsFile = groupedReferences |> Array.map(fun (_filename,maxIndexOfReference,references)-> - let assemblyResolution = references |> List.choose tcConfig.TryResolveLibWithDirectories + let assemblyResolution = references |> List.choose (fun r -> tcConfig.TryResolveLibWithDirectories r) (maxIndexOfReference, assemblyResolution)) |> Array.filter(fun (_,refs)->refs |> isNil |> not) @@ -2997,7 +2999,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = (tcConfig.resolutionEnvironment, references, tcConfig.targetFrameworkVersion, - tcConfig.TargetFrameworkDirectories, + tcConfig.GetTargetFrameworkDirectories(), targetProcessorArchitecture, tcConfig.fsharpBinariesDir, // FSharp binaries directory tcConfig.includes, // Explicit include directories @@ -3299,7 +3301,7 @@ let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaul // #nowarn declarations for the file let delayLogger = CapturingErrorLogger("Parsing") use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> delayLogger) - use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse let mutable scopedPragmas = [] try let input = @@ -3326,10 +3328,10 @@ let ParseInput (lexer,errorLogger:ErrorLogger,lexbuf:UnicodeLexing.Lexbuf,defaul // Filename is (ml/mli/fs/fsi source). Parse it to AST. //---------------------------------------------------------------------------- let ParseOneInputLexbuf (tcConfig:TcConfig,lexResourceManager,conditionalCompilationDefines,lexbuf,filename,isLastCompiland,errorLogger) = - use unwindbuildphase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindbuildphase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse try let skip = true in (* don't report whitespace from lexer *) - let lightSyntaxStatus = LightSyntaxStatus (tcConfig.ComputeLightSyntaxInitialStatus filename,true) + let lightSyntaxStatus = LightSyntaxStatus (tcConfig.ComputeLightSyntaxInitialStatus(filename),true) let lexargs = mkLexargs (filename,conditionalCompilationDefines@tcConfig.conditionalCompilationDefines,lightSyntaxStatus,lexResourceManager, ref [],errorLogger) let shortFilename = SanitizeFileName filename tcConfig.implicitIncludeDir let input = @@ -3406,14 +3408,14 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres member tcResolutions.TryFindByResolvedPath nm = resolvedPathToResolution.TryFind nm member tcResolutions.TryFindByOriginalReferenceText nm = originalReferenceToResolution.TryFind nm - static member Resolve (tcConfig:TcConfig,assemblyList:AssemblyReference list, knownUnresolved:UnresolvedAssemblyReference list) : TcAssemblyResolutions = + static member ResolveAssemblyReferences (ctok,tcConfig:TcConfig,assemblyList:AssemblyReference list, knownUnresolved:UnresolvedAssemblyReference list) : TcAssemblyResolutions = let resolved,unresolved = if tcConfig.useSimpleResolution then let resolutions = assemblyList |> List.map (fun assemblyReference -> try - Choice1Of2 (tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError assemblyReference |> Option.get) + Choice1Of2 (tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, assemblyReference) |> Option.get) with e -> errorRecovery e assemblyReference.Range Choice2Of2 assemblyReference) @@ -3421,7 +3423,8 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres let failures = resolutions |> List.choose (function Choice2Of2 x -> Some (UnresolvedAssemblyReference(x.Text,[x])) | _ -> None) successes, failures else - TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig,assemblyList,rangeStartup,ReportErrors) + RequireCompilationThread ctok // we don't want to do assemby resolution concurrently, we assume MSBuild doesn't handle this + TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig, assemblyList, rangeStartup, ReportErrors) TcAssemblyResolutions(resolved,unresolved @ knownUnresolved) @@ -3445,9 +3448,9 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres yield! tcConfig.referencedDLLs ] - static member SplitNonFoundationalResolutions (tcConfig:TcConfig) = + static member SplitNonFoundationalResolutions (ctok,tcConfig:TcConfig) = let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig - let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,tcConfig.knownUnresolvedReferences) + let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (ctok,tcConfig,assemblyList,tcConfig.knownUnresolvedReferences) let frameworkDLLs,nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) let unresolved = resolutions.GetUnresolvedReferences() #if DEBUG @@ -3471,15 +3474,15 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres if !itFailed then // idea is, put a breakpoint here and then step through let assemblyList = TcAssemblyResolutions.GetAllDllReferences tcConfig - let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,[]) + let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (ctok, tcConfig,assemblyList,[]) let _frameworkDLLs,_nonFrameworkReferences = resolutions.GetAssemblyResolutions() |> List.partition (fun r -> r.sysdir) () #endif frameworkDLLs,nonFrameworkReferences,unresolved - static member BuildFromPriorResolutions (tcConfig:TcConfig,resolutions,knownUnresolved) = + static member BuildFromPriorResolutions (ctok,tcConfig:TcConfig,resolutions,knownUnresolved) = let references = resolutions |> List.map (fun r -> r.originalReference) - TcAssemblyResolutions.Resolve(tcConfig,references,knownUnresolved) + TcAssemblyResolutions.ResolveAssemblyReferences (ctok,tcConfig,references,knownUnresolved) //---------------------------------------------------------------------------- @@ -3605,15 +3608,15 @@ let availableToOptionalCcu = function /// Represents a computation to return a TcConfig. Normally this is just a constant immutable TcConfig, /// but for F# Interactive it may be based on an underlying mutable TcConfigBuilder. type TcConfigProvider = - | TcConfigProvider of (unit -> TcConfig) - member x.Get() = (let (TcConfigProvider(f)) = x in f()) + | TcConfigProvider of (CompilationThreadToken -> TcConfig) + member x.Get(ctok) = (let (TcConfigProvider(f)) = x in f ctok) /// Get a TcConfigProvider which will return only the exact TcConfig. - static member Constant(tcConfig) = TcConfigProvider(fun () -> tcConfig) + static member Constant(tcConfig) = TcConfigProvider(fun _ctok -> tcConfig) /// Get a TcConfigProvider which will continue to respect changes in the underlying /// TcConfigBuilder rather than delivering snapshots. - static member BasedOnMutableBuilder(tcConfigB) = TcConfigProvider(fun () -> TcConfig.Create(tcConfigB,validate=false)) + static member BasedOnMutableBuilder(tcConfigB) = TcConfigProvider(fun _ctok -> TcConfig.Create(tcConfigB,validate=false)) //---------------------------------------------------------------------------- @@ -3686,7 +3689,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | Some(importsBase)-> importsBase.AllAssemblyResolutions() @ ars | None -> ars - member tcImports.TryFindDllInfo (m,assemblyName,lookupOnly) = + member tcImports.TryFindDllInfo (ctok: CompilationThreadToken, m, assemblyName, lookupOnly) = CheckDisposed() let rec look (t:TcImports) = match NameMap.tryFind assemblyName t.DllTable with @@ -3698,12 +3701,12 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti match look tcImports with | Some res -> Some res | None -> - tcImports.ImplicitLoadIfAllowed(m,assemblyName,lookupOnly) + tcImports.ImplicitLoadIfAllowed(ctok, m, assemblyName, lookupOnly) look tcImports - member tcImports.FindDllInfo (m,assemblyName) = - match tcImports.TryFindDllInfo (m,assemblyName,lookupOnly=false) with + member tcImports.FindDllInfo (ctok, m, assemblyName) = + match tcImports.TryFindDllInfo (ctok, m, assemblyName, lookupOnly=false) with | Some res -> res | None -> error(Error(FSComp.SR.buildCouldNotResolveAssembly(assemblyName),m)) @@ -3722,7 +3725,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti List.map (fun x -> x.FSharpViewOfMetadata) (tcImports.GetImportedAssemblies()) // This is the main "assembly reference --> assembly" resolution routine. - member tcImports.FindCcuInfo (m,assemblyName,lookupOnly) = + member tcImports.FindCcuInfo (ctok, m, assemblyName, lookupOnly) = CheckDisposed() let rec look (t:TcImports) = match NameMap.tryFind assemblyName t.CcuTable with @@ -3735,36 +3738,36 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti match look tcImports with | Some res -> ResolvedImportedAssembly(res) | None -> - tcImports.ImplicitLoadIfAllowed(m,assemblyName,lookupOnly) + tcImports.ImplicitLoadIfAllowed(ctok, m, assemblyName, lookupOnly) match look tcImports with | Some res -> ResolvedImportedAssembly(res) | None -> UnresolvedImportedAssembly(assemblyName) - member tcImports.FindCcu (m, assemblyName,lookupOnly) = + member tcImports.FindCcu (ctok, m, assemblyName,lookupOnly) = CheckDisposed() - match tcImports.FindCcuInfo(m,assemblyName,lookupOnly) with + match tcImports.FindCcuInfo(ctok, m, assemblyName, lookupOnly) with | ResolvedImportedAssembly(importedAssembly) -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) | UnresolvedImportedAssembly(assemblyName) -> UnresolvedCcu(assemblyName) - member tcImports.FindCcuFromAssemblyRef(m,assref:ILAssemblyRef) = + member tcImports.FindCcuFromAssemblyRef(ctok, m, assref:ILAssemblyRef) = CheckDisposed() - match tcImports.FindCcuInfo(m,assref.Name,lookupOnly=false) with + match tcImports.FindCcuInfo(ctok, m, assref.Name, lookupOnly=false) with | ResolvedImportedAssembly(importedAssembly) -> ResolvedCcu(importedAssembly.FSharpViewOfMetadata) | UnresolvedImportedAssembly _ -> UnresolvedCcu(assref.QualifiedName) #if EXTENSIONTYPING - member tcImports.GetProvidedAssemblyInfo(m, assembly: Tainted) = + member tcImports.GetProvidedAssemblyInfo(ctok, m, assembly: Tainted) = let anameOpt = assembly.PUntaint((fun assembly -> match assembly with null -> None | a -> Some (a.GetName())), m) match anameOpt with | None -> false, None | Some aname -> let ilShortAssemName = aname.Name - match tcImports.FindCcu (m, ilShortAssemName, lookupOnly=true) with + match tcImports.FindCcu (ctok, m, ilShortAssemName, lookupOnly=true) with | ResolvedCcu ccu -> if ccu.IsProviderGenerated then - let dllinfo = tcImports.FindDllInfo(m,ilShortAssemName) + let dllinfo = tcImports.FindDllInfo(ctok,m,ilShortAssemName) true, dllinfo.ProviderGeneratedStaticLinkMap else false, None @@ -3850,10 +3853,10 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed // then the reader is closed. - member tcImports.OpenILBinaryModule(filename,m) = + member tcImports.OpenILBinaryModule(ctok,filename,m) = try CheckDisposed() - let tcConfig = tcConfigP.Get() + let tcConfig = tcConfigP.Get(ctok) let pdbPathOption = // We open the pdb file if one exists parallel to the binary we // are reading, so that --standalone will preserve debug information. @@ -3874,18 +3877,18 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message),m)) (* auxModTable is used for multi-module assemblies *) - member tcImports.MkLoaderForMultiModuleILAssemblies m = + member tcImports.MkLoaderForMultiModuleILAssemblies ctok m = CheckDisposed() let auxModTable = HashMultiMap(10, HashIdentity.Structural) fun viewedScopeRef -> - let tcConfig = tcConfigP.Get() + let tcConfig = tcConfigP.Get(ctok) match viewedScopeRef with | ILScopeRef.Module modref -> let key = modref.Name if not (auxModTable.ContainsKey(key)) then - let resolution = tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError (AssemblyReference(m,key,None)) |> Option.get - let ilModule,_ = tcImports.OpenILBinaryModule(resolution.resolvedPath,m) + let resolution = tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, AssemblyReference(m,key,None)) |> Option.get + let ilModule,_ = tcImports.OpenILBinaryModule(ctok,resolution.resolvedPath,m) auxModTable.[key] <- ilModule auxModTable.[key] @@ -3903,10 +3906,10 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti CheckDisposed() let loaderInterface = { new Import.AssemblyLoader with - member x.LoadAssembly (m, ilAssemblyRef) = - tcImports.FindCcuFromAssemblyRef(m,ilAssemblyRef) + member x.FindCcuFromAssemblyRef (ctok, m, ilAssemblyRef) = + tcImports.FindCcuFromAssemblyRef (ctok, m,ilAssemblyRef) #if EXTENSIONTYPING - member x.GetProvidedAssemblyInfo (m,assembly) = tcImports.GetProvidedAssemblyInfo (m,assembly) + member x.GetProvidedAssemblyInfo (ctok, m, assembly) = tcImports.GetProvidedAssemblyInfo (ctok, m, assembly) member x.RecordGeneratedTypeRoot root = tcImports.RecordGeneratedTypeRoot root #endif } @@ -3986,7 +3989,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | _ -> failwith "Unexpected representation in namespace entity referred to by a type provider" member tcImports.ImportTypeProviderExtensions - (tcConfig:TcConfig, + (ctok, tcConfig:TcConfig, fileNameOfRuntimeAssembly, ilScopeRefOfRuntimeAssembly, runtimeAssemblyAttributes:ILAttribute list, @@ -4008,7 +4011,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Find the SystemRuntimeAssemblyVersion value to report in the TypeProviderConfig. let systemRuntimeAssemblyVersion = let primaryAssemblyRef = tcConfig.PrimaryAssemblyDllReference() - let resolution = tcConfig.ResolveLibWithDirectories CcuLoadFailureAction.RaiseError primaryAssemblyRef |> Option.get + let resolution = tcConfig.ResolveLibWithDirectories (CcuLoadFailureAction.RaiseError, primaryAssemblyRef) |> Option.get // MSDN: this method causes the file to be opened and closed, but the assembly is not added to this domain let name = System.Reflection.AssemblyName.GetAssemblyName(resolution.resolvedPath) name.Version @@ -4083,7 +4086,9 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti for providedNestedNamespace in providedNamespace.PApplyArray((fun provider -> provider.GetNestedNamespaces()), "GetNestedNamespaces", m) do loop providedNestedNamespace + RequireCompilationThread ctok // IProvidedType.GetNamespaces is an example of a type provider call let providedNamespaces = provider.PApplyArray((fun r -> r.GetNamespaces()), "GetNamespaces", m) + for providedNamespace in providedNamespaces do loop providedNamespace with e -> @@ -4109,10 +4114,10 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Compact Framework binaries must use this. However it is not // clear when else it is required, e.g. for Mono. - member tcImports.PrepareToImportReferencedILAssembly m filename (dllinfo:ImportedBinary) = + member tcImports.PrepareToImportReferencedILAssembly (ctok, m, filename, dllinfo:ImportedBinary) = CheckDisposed() - let tcConfig = tcConfigP.Get() - tcConfig.CheckFSharpBinary(filename,dllinfo.ILAssemblyRefs,m) + let tcConfig = tcConfigP.Get(ctok) + tcConfig.CheckFSharpBinary (filename,dllinfo.ILAssemblyRefs,m) assert dllinfo.RawMetadata.TryGetRawILModule().IsSome let ilModule = dllinfo.RawMetadata.TryGetRawILModule().Value let ilScopeRef = dllinfo.ILScopeRef @@ -4123,7 +4128,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let nm = aref.Name if verbose then dprintn ("Converting IL assembly to F# data structures "+nm) - let auxModuleLoader = tcImports.MkLoaderForMultiModuleILAssemblies m + let auxModuleLoader = tcImports.MkLoaderForMultiModuleILAssemblies ctok m let invalidateCcu = new Event<_>() let ccu = Import.ImportILAssembly(tcImports.GetImportMap,m,auxModuleLoader,ilScopeRef,tcConfig.implicitIncludeDir, Some filename,ilModule,invalidateCcu.Publish) @@ -4142,15 +4147,15 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti tcImports.RegisterCcu(ccuinfo) let phase2 () = #if EXTENSIONTYPING - ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) + ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (ctok, tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) #endif [ResolvedImportedAssembly(ccuinfo)] phase2 - member tcImports.PrepareToImportReferencedFSharpAssembly m filename (dllinfo:ImportedBinary) = + member tcImports.PrepareToImportReferencedFSharpAssembly (ctok, m, filename, dllinfo:ImportedBinary) = CheckDisposed() - let tcConfig = tcConfigP.Get() - tcConfig.CheckFSharpBinary(filename,dllinfo.ILAssemblyRefs,m) + let tcConfig = tcConfigP.Get(ctok) + tcConfig.CheckFSharpBinary (filename, dllinfo.ILAssemblyRefs, m) let ilModule = dllinfo.RawMetadata let ilScopeRef = dllinfo.ILScopeRef @@ -4189,7 +4194,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti #endif UsesFSharp20PlusQuotations = minfo.usesQuotations MemberSignatureEquality= (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) - TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap,m, ilModule.GetRawTypeForwarders()) } + TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, ilModule.GetRawTypeForwarders()) } let ccu = CcuThunk.Create(ccuName, ccuData) @@ -4201,7 +4206,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti None | Some info -> let data = GetOptimizationData (filename, ilScopeRef, ilModule.TryGetRawILModule(), info) - let res = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(m,nm,lookupOnly=false))) + let res = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(ctok,m,nm,lookupOnly=false))) if verbose then dprintf "found optimization data for CCU %s\n" ccuName Some res) let ilg = defaultArg ilGlobalsOpt EcmaMscorlibILGlobals @@ -4220,7 +4225,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti match ilModule.TryGetRawILModule() with | None -> () // no type providers can be used without a real IL Module present | Some ilModule -> - ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) + ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (ctok, tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) #else () #endif @@ -4231,7 +4236,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let phase2 () = (* Relink *) (* dprintf "Phase2: %s\n" filename; REMOVE DIAGNOSTICS *) - ccuRawDataAndInfos |> List.iter (fun (data,_,_) -> data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(m,nm,lookupOnly=false))) |> ignore) + ccuRawDataAndInfos |> List.iter (fun (data,_,_) -> data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(ctok,m,nm,lookupOnly=false))) |> ignore) #if EXTENSIONTYPING ccuRawDataAndInfos |> List.iter (fun (_,_,phase2) -> phase2()) #endif @@ -4239,7 +4244,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti phase2 - member tcImports.RegisterAndPrepareToImportReferencedDll (r:AssemblyResolution) : _*(unit -> AvailableImportedAssembly list)= + member tcImports.RegisterAndPrepareToImportReferencedDll (ctok, r:AssemblyResolution) : _ * (unit -> AvailableImportedAssembly list)= CheckDisposed() let m = r.originalReference.Range let filename = r.resolvedPath @@ -4252,15 +4257,15 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti match contentsOpt with | Some ilb -> ilb | None -> - let ilModule,ilAssemblyRefs = tcImports.OpenILBinaryModule(filename,m) + let ilModule,ilAssemblyRefs = tcImports.OpenILBinaryModule(ctok, filename, m) RawFSharpAssemblyDataBackedByFileOnDisk (ilModule, ilAssemblyRefs) :> IRawFSharpAssemblyData let ilShortAssemName = assemblyData.ShortAssemblyName let ilScopeRef = assemblyData.ILScopeRef if tcImports.IsAlreadyRegistered ilShortAssemName then - let dllinfo = tcImports.FindDllInfo(m,ilShortAssemName) - let phase2() = [tcImports.FindCcuInfo(m,ilShortAssemName,lookupOnly=true)] + let dllinfo = tcImports.FindDllInfo(ctok,m,ilShortAssemName) + let phase2() = [tcImports.FindCcuInfo(ctok,m,ilShortAssemName,lookupOnly=true)] dllinfo,phase2 else let dllinfo = @@ -4279,23 +4284,23 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti if assemblyData.HasAnyFSharpSignatureDataAttribute then if not (assemblyData.HasMatchingFSharpSignatureDataAttribute(ilg)) then errorR(Error(FSComp.SR.buildDifferentVersionMustRecompile(filename),m)) - tcImports.PrepareToImportReferencedILAssembly m filename dllinfo + tcImports.PrepareToImportReferencedILAssembly (ctok, m, filename, dllinfo) else try - tcImports.PrepareToImportReferencedFSharpAssembly m filename dllinfo + tcImports.PrepareToImportReferencedFSharpAssembly (ctok, m, filename, dllinfo) with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message),m)) else - tcImports.PrepareToImportReferencedILAssembly m filename dllinfo + tcImports.PrepareToImportReferencedILAssembly (ctok, m, filename, dllinfo) dllinfo,phase2 - member tcImports.RegisterAndImportReferencedAssemblies (nms:AssemblyResolution list) = + member tcImports.RegisterAndImportReferencedAssemblies (ctok, nms:AssemblyResolution list) = CheckDisposed() let dllinfos,phase2s = nms |> List.choose (fun nm -> try - Some(tcImports.RegisterAndPrepareToImportReferencedDll nm) + Some(tcImports.RegisterAndPrepareToImportReferencedDll (ctok, nm)) with e -> errorR(Error(FSComp.SR.buildProblemReadingAssembly(nm.resolvedPath, e.Message),nm.originalReference.Range)) None) @@ -4303,22 +4308,22 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let ccuinfos = (List.collect (fun phase2 -> phase2()) phase2s) dllinfos,ccuinfos - member tcImports.DoRegisterAndImportReferencedAssemblies(nms) = + member tcImports.DoRegisterAndImportReferencedAssemblies(ctok, nms) = CheckDisposed() - tcImports.RegisterAndImportReferencedAssemblies(nms) |> ignore + tcImports.RegisterAndImportReferencedAssemblies(ctok, nms) |> ignore - member tcImports.ImplicitLoadIfAllowed (m, assemblyName, lookupOnly) = + member tcImports.ImplicitLoadIfAllowed (ctok, m, assemblyName, lookupOnly) = CheckDisposed() // If the user is asking for the default framework then also try to resolve other implicit assemblies as they are discovered. // Using this flag to mean 'allow implicit discover of assemblies'. - let tcConfig = tcConfigP.Get() + let tcConfig = tcConfigP.Get(ctok) if not lookupOnly && tcConfig.implicitlyResolveAssemblies then let tryFile speculativeFileName = - let foundFile = tcImports.TryResolveAssemblyReference (AssemblyReference (m, speculativeFileName, None), ResolveAssemblyReferenceMode.Speculative) + let foundFile = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, speculativeFileName, None), ResolveAssemblyReferenceMode.Speculative) match foundFile with | OkResult (warns, res) -> ReportWarnings warns - tcImports.DoRegisterAndImportReferencedAssemblies(res) + tcImports.DoRegisterAndImportReferencedAssemblies(ctok,res) true | ErrorResult (_warns, _err) -> // Throw away warnings and errors - this is speculative loading @@ -4328,9 +4333,9 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti else tryFile (assemblyName + ".exe") |> ignore #if EXTENSIONTYPING - member tcImports.TryFindProviderGeneratedAssemblyByName(assemblyName:string) : System.Reflection.Assembly option = + member tcImports.TryFindProviderGeneratedAssemblyByName(ctok, assemblyName:string) : System.Reflection.Assembly option = // The assembly may not be in the resolutions, but may be in the load set including EST injected assemblies - match tcImports.TryFindDllInfo (range0,assemblyName,lookupOnly=true) with + match tcImports.TryFindDllInfo (ctok, range0, assemblyName, lookupOnly=true) with | Some res -> // Provider-generated assemblies don't necessarily have an on-disk representation we can load. res.ProviderGeneratedAssembly @@ -4354,8 +4359,8 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | _ -> None *) - member tcImports.TryResolveAssemblyReference(assemblyReference:AssemblyReference,mode:ResolveAssemblyReferenceMode) : OperationResult = - let tcConfig = tcConfigP.Get() + member tcImports.TryResolveAssemblyReference(ctok, assemblyReference:AssemblyReference, mode:ResolveAssemblyReferenceMode) : OperationResult = + let tcConfig = tcConfigP.Get(ctok) // First try to lookup via the original reference text. match resolutions.TryFindByOriginalReference assemblyReference with | Some assemblyResolution -> @@ -4366,12 +4371,12 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti | Some assemblyResolution -> ResultD [assemblyResolution] | None -> - if tcConfigP.Get().useSimpleResolution then + if tcConfigP.Get(ctok).useSimpleResolution then let action = match mode with | ResolveAssemblyReferenceMode.ReportErrors -> CcuLoadFailureAction.RaiseError | ResolveAssemblyReferenceMode.Speculative -> CcuLoadFailureAction.ReturnNone - match tcConfig.ResolveLibWithDirectories action assemblyReference with + match tcConfig.ResolveLibWithDirectories (action, assemblyReference) with | Some resolved -> resolutions <- resolutions.AddResolutionResults [resolved] ResultD [resolved] @@ -4380,7 +4385,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti else // This is a previously unencounterd assembly. Resolve it and add it to the list. // But don't cache resolution failures because the assembly may appear on the disk later. - let resolved,unresolved = TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig,[ assemblyReference ],assemblyReference.Range,mode) + let resolved,unresolved = TcConfig.TryResolveLibsUsingMSBuildRules(tcConfig, [ assemblyReference ], assemblyReference.Range, mode) match resolved,unresolved with | (assemblyResolution::_,_) -> resolutions <- resolutions.AddResolutionResults resolved @@ -4395,27 +4400,27 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti - member tcImports.ResolveAssemblyReference(assemblyReference,mode) : AssemblyResolution list = - CommitOperationResult(tcImports.TryResolveAssemblyReference(assemblyReference,mode)) + member tcImports.ResolveAssemblyReference(ctok, assemblyReference, mode) : AssemblyResolution list = + CommitOperationResult(tcImports.TryResolveAssemblyReference(ctok, assemblyReference,mode)) // Note: This returns a TcImports object. However, framework TcImports are not currently disposed. The only reason // we dispose TcImports is because we need to dispose type providers, and type providers are never included in the framework DLL set. // // If this ever changes then callers may need to begin disposing the TcImports (though remember, not before all derived // non-frameworkk TcImports built related to this framework TcImports are disposed). - static member BuildFrameworkTcImports (tcConfigP:TcConfigProvider, frameworkDLLs, nonFrameworkDLLs) = + static member BuildFrameworkTcImports (ctok, tcConfigP:TcConfigProvider, frameworkDLLs, nonFrameworkDLLs) = - let tcConfig = tcConfigP.Get() - let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,frameworkDLLs,[]) - let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,nonFrameworkDLLs,[]) + let tcConfig = tcConfigP.Get(ctok) + let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(ctok, tcConfig, frameworkDLLs, []) + let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(ctok, tcConfig, nonFrameworkDLLs, []) // Note: TcImports are disposable - the caller owns this object and must dispose let frameworkTcImports = new TcImports(tcConfigP,tcResolutions,None,None) let primaryScopeRef = let primaryAssemblyReference = tcConfig.PrimaryAssemblyDllReference() - let primaryAssemblyResolution = frameworkTcImports.ResolveAssemblyReference(primaryAssemblyReference,ResolveAssemblyReferenceMode.ReportErrors) - match frameworkTcImports.RegisterAndImportReferencedAssemblies(primaryAssemblyResolution) with + let primaryAssemblyResolution = frameworkTcImports.ResolveAssemblyReference(ctok, primaryAssemblyReference, ResolveAssemblyReferenceMode.ReportErrors) + match frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, primaryAssemblyResolution) with | (_, [ResolvedImportedAssembly(ccu)]) -> ccu.FSharpViewOfMetadata.ILScopeRef | _ -> failwith "unexpected" @@ -4423,7 +4428,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti frameworkTcImports.SetILGlobals ilGlobals // Load the rest of the framework DLLs all at once (they may be mutually recursive) - frameworkTcImports.DoRegisterAndImportReferencedAssemblies (tcResolutions.GetAssemblyResolutions()) + frameworkTcImports.DoRegisterAndImportReferencedAssemblies (ctok, tcResolutions.GetAssemblyResolutions()) // These are the DLLs we can search for well-known types let sysCcus = @@ -4456,7 +4461,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti match resolvedAssemblyRef with | Some coreLibraryResolution -> - match frameworkTcImports.RegisterAndImportReferencedAssemblies([coreLibraryResolution]) with + match frameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, [coreLibraryResolution]) with | (_, [ResolvedImportedAssembly(fslibCcuInfo) ]) -> fslibCcuInfo | _ -> error(InternalError("BuildFrameworkTcImports: no successful import of "+coreLibraryResolution.resolvedPath,coreLibraryResolution.originalReference.Range)) @@ -4495,12 +4500,12 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // Note: This returns a TcImports object. TcImports are disposable - the caller owns the returned TcImports object // and when hosted in Visual Studio or another long-running process must dispose this object. - static member BuildNonFrameworkTcImports (tcConfigP:TcConfigProvider, tcGlobals:TcGlobals, baseTcImports, nonFrameworkReferences, knownUnresolved) = - let tcConfig = tcConfigP.Get() - let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(tcConfig,nonFrameworkReferences,knownUnresolved) + static member BuildNonFrameworkTcImports (ctok, tcConfigP:TcConfigProvider, tcGlobals:TcGlobals, baseTcImports, nonFrameworkReferences, knownUnresolved) = + let tcConfig = tcConfigP.Get(ctok) + let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(ctok, tcConfig, nonFrameworkReferences, knownUnresolved) let references = tcResolutions.GetAssemblyResolutions() let tcImports = new TcImports(tcConfigP,tcResolutions,Some baseTcImports, Some tcGlobals.ilg) - tcImports.DoRegisterAndImportReferencedAssemblies(references) + tcImports.DoRegisterAndImportReferencedAssemblies(ctok, references) tcImports.ReportUnresolvedAssemblyReferences(knownUnresolved) tcImports @@ -4508,12 +4513,12 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // and if hosted in Visual Studio or another long-running process must dispose this object. However this // function is currently only used from fsi.exe. If we move to a long-running hosted evaluation service API then // we should start disposing these objects. - static member BuildTcImports(tcConfigP:TcConfigProvider) = - let tcConfig = tcConfigP.Get() + static member BuildTcImports(ctok,tcConfigP:TcConfigProvider) = + let tcConfig = tcConfigP.Get(ctok) //let foundationalTcImports,tcGlobals = TcImports.BuildFoundationalTcImports(tcConfigP) - let frameworkDLLs,nonFrameworkReferences,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) - let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (tcConfigP,frameworkDLLs,nonFrameworkReferences) - let tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP,tcGlobals,frameworkTcImports,nonFrameworkReferences,knownUnresolved) + let frameworkDLLs,nonFrameworkReferences,knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(ctok,tcConfig) + let tcGlobals,frameworkTcImports = TcImports.BuildFrameworkTcImports (ctok, tcConfigP, frameworkDLLs, nonFrameworkReferences) + let tcImports = TcImports.BuildNonFrameworkTcImports(ctok, tcConfigP, tcGlobals, frameworkTcImports, nonFrameworkReferences, knownUnresolved) tcGlobals,tcImports interface System.IDisposable with @@ -4529,9 +4534,9 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti /// Process #r in F# Interactive. /// Adds the reference to the tcImports and add the ccu to the type checking environment. -let RequireDLL (tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = - let resolutions = CommitOperationResult(tcImports.TryResolveAssemblyReference(AssemblyReference(m,file,None),ResolveAssemblyReferenceMode.ReportErrors)) - let dllinfos,ccuinfos = tcImports.RegisterAndImportReferencedAssemblies(resolutions) +let RequireDLL (ctok, tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = + let resolutions = CommitOperationResult(tcImports.TryResolveAssemblyReference(ctok, AssemblyReference(m,file,None),ResolveAssemblyReferenceMode.ReportErrors)) + let dllinfos,ccuinfos = tcImports.RegisterAndImportReferencedAssemblies(ctok, resolutions) let asms = ccuinfos |> List.map (function @@ -4549,12 +4554,9 @@ let ProcessMetaCommandsFromInput (nowarnF: 'state -> range * string -> 'state, dllRequireF: 'state -> range * string -> 'state, loadSourceF: 'state -> range * string -> unit) - (tcConfig:TcConfigBuilder) - inp - pathOfMetaCommandSource - state0 = + (tcConfig:TcConfigBuilder, inp, pathOfMetaCommandSource, state0) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse let canHaveScriptMetaCommands = match inp with @@ -4658,32 +4660,32 @@ let ProcessMetaCommandsFromInput let state = List.fold ProcessMetaCommandsFromModuleImpl state impls state -let ApplyNoWarnsToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = +let ApplyNoWarnsToTcConfig (tcConfig:TcConfig, inp:ParsedInput, pathOfMetaCommandSource) = // Clone let tcConfigB = tcConfig.CloneOfOriginalBuilder - let addNoWarn = fun () (m,s) -> tcConfigB.TurnWarningOff(m,s) + let addNoWarn = fun () (m,s) -> tcConfigB.TurnWarningOff(m, s) let addReferencedAssemblyByPath = fun () (_m,_s) -> () let addLoadedSource = fun () (_m,_s) -> () - ProcessMetaCommandsFromInput (addNoWarn, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () - TcConfig.Create(tcConfigB,validate=false) + ProcessMetaCommandsFromInput (addNoWarn, addReferencedAssemblyByPath, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) + TcConfig.Create(tcConfigB, validate=false) -let ApplyMetaCommandsFromInputToTcConfig (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = +let ApplyMetaCommandsFromInputToTcConfig (tcConfig:TcConfig, inp:ParsedInput, pathOfMetaCommandSource) = // Clone let tcConfigB = tcConfig.CloneOfOriginalBuilder let getWarningNumber = fun () _ -> () let addReferencedAssemblyByPath = fun () (m,s) -> tcConfigB.AddReferencedAssemblyByPath(m,s) let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) - ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () - TcConfig.Create(tcConfigB,validate=false) + ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) + TcConfig.Create(tcConfigB, validate=false) //---------------------------------------------------------------------------- // Compute the load closure of a set of script files //-------------------------------------------------------------------------- -let GetAssemblyResolutionInformation(tcConfig : TcConfig) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) +let GetAssemblyResolutionInformation(ctok, tcConfig : TcConfig) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter let assemblyList = TcAssemblyResolutions.GetAllDllReferences(tcConfig) - let resolutions = TcAssemblyResolutions.Resolve(tcConfig,assemblyList,[]) + let resolutions = TcAssemblyResolutions.ResolveAssemblyReferences (ctok, tcConfig, assemblyList, []) resolutions.GetAssemblyResolutions(),resolutions.GetUnresolvedReferences() @@ -4798,26 +4800,26 @@ module private ScriptPreprocessClosure = errorRecovery e m [] - let ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (tcConfig:TcConfig) (inp:ParsedInput,pathOfMetaCommandSource) = + let ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (tcConfig:TcConfig, inp:ParsedInput, pathOfMetaCommandSource) = let tcConfigB = tcConfig.CloneOfOriginalBuilder let nowarns = ref [] let getWarningNumber = fun () (m,s) -> nowarns := (s,m) :: !nowarns let addReferencedAssemblyByPath = fun () (m,s) -> tcConfigB.AddReferencedAssemblyByPath(m,s) let addLoadedSource = fun () (m,s) -> tcConfigB.AddLoadedSource(m,s,pathOfMetaCommandSource) try - ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) tcConfigB inp pathOfMetaCommandSource () + ProcessMetaCommandsFromInput (getWarningNumber, addReferencedAssemblyByPath, addLoadedSource) (tcConfigB, inp, pathOfMetaCommandSource, ()) with ReportedError _ -> // Recover by using whatever did end up in the tcConfig () try - TcConfig.Create(tcConfigB,validate=false),nowarns + TcConfig.Create(tcConfigB, validate=false),nowarns with ReportedError _ -> // Recover by using a default TcConfig. let tcConfigB = tcConfig.CloneOfOriginalBuilder - TcConfig.Create(tcConfigB,validate=false),nowarns + TcConfig.Create(tcConfigB, validate=false),nowarns - let FindClosureFiles(closureSources,tcConfig:TcConfig,codeContext,lexResourceManager:Lexhelp.LexResourceManager) = + let FindClosureFiles(closureSources, tcConfig:TcConfig, codeContext, lexResourceManager:Lexhelp.LexResourceManager) = let tcConfig = ref tcConfig let observedSources = Observed() @@ -4829,7 +4831,7 @@ module private ScriptPreprocessClosure = let parseResult, parseDiagnostics = let errorLogger = CapturingErrorLogger("FindClosureParse") use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) - let result = ParseScriptText(filename,source,!tcConfig,codeContext,lexResourceManager,errorLogger) + let result = ParseScriptText (filename, source, !tcConfig, codeContext, lexResourceManager, errorLogger) result, errorLogger.Diagnostics match parseResult with @@ -4839,7 +4841,7 @@ module private ScriptPreprocessClosure = let pathOfMetaCommandSource = Path.GetDirectoryName(filename) let preSources = (!tcConfig).GetAvailableLoadedSources() - let tcConfigResult, noWarns = ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn !tcConfig (parsedScriptAst,pathOfMetaCommandSource) + let tcConfigResult, noWarns = ApplyMetaCommandsFromInputToTcConfigAndGatherNoWarn (!tcConfig, parsedScriptAst, pathOfMetaCommandSource) tcConfig := tcConfigResult // We accumulate the tcConfig in order to collect assembly references let postSources = (!tcConfig).GetAvailableLoadedSources() @@ -4869,7 +4871,7 @@ module private ScriptPreprocessClosure = closureSources |> List.collect loop, !tcConfig /// Reduce the full directive closure into LoadClosure - let GetLoadClosure(rootFilename,closureFiles,tcConfig:TcConfig,codeContext) = + let GetLoadClosure(ctok, rootFilename, closureFiles, tcConfig:TcConfig, codeContext) = // Mark the last file as isLastCompiland. let closureFiles = @@ -4890,8 +4892,8 @@ module private ScriptPreprocessClosure = let references, unresolvedReferences, resolutionDiagnostics = let errorLogger = CapturingErrorLogger("GetLoadClosure") - use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) - let references,unresolvedReferences = GetAssemblyResolutionInformation(tcConfig) + use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> errorLogger) + let references,unresolvedReferences = GetAssemblyResolutionInformation(ctok, tcConfig) let references = references |> List.map (fun ar -> ar.resolvedPath,ar) references, unresolvedReferences, errorLogger.Diagnostics @@ -4929,42 +4931,42 @@ module private ScriptPreprocessClosure = result /// Given source text, find the full load closure. Used from service.fs, when editing a script file - let GetFullClosureOfScriptSource(referenceResolver,filename,source,codeContext,useSimpleResolution,useFsiAuxLib,lexResourceManager:Lexhelp.LexResourceManager,applyCommmandLineArgs,assumeDotNetFramework) = + let GetFullClosureOfScriptSource(ctok, referenceResolver, filename, source, codeContext, useSimpleResolution,useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) = // Resolve the basic references such as FSharp.Core.dll first, before processing any #I directives in the script // // This is tries to mimic the action of running the script in F# Interactive - the initial context for scripting is created // first, then #I and other directives are processed. let references0 = - let tcConfig = CreateScriptSourceTcConfig(referenceResolver,filename,codeContext,useSimpleResolution,useFsiAuxLib,None,applyCommmandLineArgs,assumeDotNetFramework) - let resolutions0,_unresolvedReferences = GetAssemblyResolutionInformation(tcConfig) + let tcConfig = CreateScriptSourceTcConfig(referenceResolver, filename, codeContext, useSimpleResolution, useFsiAuxLib, None, applyCommmandLineArgs, assumeDotNetFramework) + let resolutions0,_unresolvedReferences = GetAssemblyResolutionInformation(ctok, tcConfig) let references0 = resolutions0 |> List.map (fun r->r.originalReference.Range,r.resolvedPath) |> Seq.distinct |> List.ofSeq references0 - let tcConfig = CreateScriptSourceTcConfig(referenceResolver,filename,codeContext,useSimpleResolution,useFsiAuxLib,Some references0,applyCommmandLineArgs,assumeDotNetFramework) + let tcConfig = CreateScriptSourceTcConfig(referenceResolver, filename, codeContext, useSimpleResolution, useFsiAuxLib, Some references0, applyCommmandLineArgs, assumeDotNetFramework) let closureSources = [ClosureSource(filename,range0,source,true)] - let closureFiles,tcConfig = FindClosureFiles(closureSources,tcConfig,codeContext,lexResourceManager) - GetLoadClosure(filename,closureFiles,tcConfig,codeContext) + let closureFiles,tcConfig = FindClosureFiles(closureSources, tcConfig, codeContext, lexResourceManager) + GetLoadClosure(ctok, filename, closureFiles, tcConfig, codeContext) /// Given source filename, find the full load closure /// Used from fsi.fs and fsc.fs, for #load and command line - let GetFullClosureOfScriptFiles(tcConfig:TcConfig,files:(string*range) list,codeContext,lexResourceManager:Lexhelp.LexResourceManager) = + let GetFullClosureOfScriptFiles(ctok, tcConfig:TcConfig,files:(string*range) list,codeContext,lexResourceManager:Lexhelp.LexResourceManager) = let mainFile = fst (List.last files) let closureSources = files |> List.collect (fun (filename,m) -> ClosureSourceOfFilename(filename,m,tcConfig.inputCodePage,true)) - let closureFiles,tcConfig = FindClosureFiles(closureSources,tcConfig,codeContext,lexResourceManager) - GetLoadClosure(mainFile,closureFiles,tcConfig,codeContext) + let closureFiles,tcConfig = FindClosureFiles(closureSources, tcConfig, codeContext, lexResourceManager) + GetLoadClosure(ctok, mainFile, closureFiles, tcConfig, codeContext) type LoadClosure with // Used from service.fs, when editing a script file - static member ComputeClosureOfSourceText(referenceResolver,filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) : LoadClosure = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - ScriptPreprocessClosure.GetFullClosureOfScriptSource(referenceResolver,filename,source,codeContext,useSimpleResolution,useFsiAuxLib, lexResourceManager, applyCommmandLineArgs,assumeDotNetFramework) + static member ComputeClosureOfSourceText(ctok, referenceResolver, filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) : LoadClosure = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + ScriptPreprocessClosure.GetFullClosureOfScriptSource(ctok, referenceResolver, filename, source, codeContext, useSimpleResolution, useFsiAuxLib, lexResourceManager, applyCommmandLineArgs,assumeDotNetFramework) /// Used from fsi.fs and fsc.fs, for #load and command line. /// The resulting references are then added to a TcConfig. - static member ComputeClosureOfSourceFiles (tcConfig:TcConfig, files:(string*range) list, codeContext, lexResourceManager:Lexhelp.LexResourceManager) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) - ScriptPreprocessClosure.GetFullClosureOfScriptFiles (tcConfig, files, codeContext, lexResourceManager) + static member ComputeClosureOfSourceFiles (ctok, tcConfig:TcConfig, files:(string*range) list, codeContext, lexResourceManager:Lexhelp.LexResourceManager) = + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse + ScriptPreprocessClosure.GetFullClosureOfScriptFiles (ctok, tcConfig, files, codeContext, lexResourceManager) @@ -5095,10 +5097,13 @@ let GetInitialTcState(m,ccuName,tcConfig:TcConfig,tcGlobals,tcImports:TcImports, /// Typecheck a single file (or interactive entry into F# Interactive) let TypeCheckOneInputEventually - (checkForErrors , tcConfig:TcConfig, tcImports:TcImports, + (checkForErrors, tcConfig:TcConfig, tcImports:TcImports, tcGlobals, prefixPathOpt, tcSink, tcState: TcState, inp: ParsedInput) = eventually { try + let! ctok = Eventually.token + RequireCompilationThread ctok // Everything here requires the compilation thread since it works on the TAST + CheckSimulateException(tcConfig) let (RootSigsAndImpls(rootSigs,rootImpls,allSigModulTyp,allImplementedSigModulTyp)) = tcState.tcsRootSigsAndImpls let m = inp.Range @@ -5205,11 +5210,12 @@ let TypeCheckOneInputEventually } /// Typecheck a single file (or interactive entry into F# Interactive) -let TypeCheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt) tcState inp = +let TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt) tcState inp = // 'use' ensures that the warning handler is restored at the end use unwindEL = PushErrorLoggerPhaseUntilUnwind(fun oldLogger -> GetErrorLoggerFilteringByScopedPragmas(false,GetScopedPragmasForInput(inp),oldLogger) ) - use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) - TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp) |> Eventually.force + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck + TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp) + |> Eventually.force ctok /// Finish checking multiple files (or one interactive entry into F# Interactive) let TypeCheckMultipleInputsFinish(results,tcState: TcState) = @@ -5223,8 +5229,8 @@ let TypeCheckMultipleInputsFinish(results,tcState: TcState) = (tcEnvAtEndOfLastFile,topAttrs,mimpls),tcState /// Check multiple files (or one interactive entry into F# Interactive) -let TypeCheckMultipleInputs (checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = - let results,tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInput (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) +let TypeCheckMultipleInputs (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = + let results,tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) TypeCheckMultipleInputsFinish(results,tcState) let TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input) = @@ -5245,9 +5251,9 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) = tcState, declaredImpls -let TypeCheckClosedInputSet (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = +let TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions - let (tcEnvAtEndOfLastFile, topAttrs, mimpls),tcState = TypeCheckMultipleInputs (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) + let (tcEnvAtEndOfLastFile, topAttrs, mimpls),tcState = TypeCheckMultipleInputs (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) let tcState, declaredImpls = TypeCheckClosedInputSetFinish (mimpls, tcState) tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 7903657538..31f7232d85 100755 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -499,7 +499,7 @@ type TcConfig = member ComputeLightSyntaxInitialStatus : string -> bool - member TargetFrameworkDirectories : string list + member GetTargetFrameworkDirectories : unit -> string list /// Get the loaded sources that exist and issue a warning for the ones that don't member GetAvailableLoadedSources : unit -> (range*string) list @@ -507,7 +507,8 @@ type TcConfig = member ComputeCanContainEntryPoint : sourceFiles:string list -> bool list *bool /// File system query based on TcConfig settings - member ResolveSourceFile : range * string * string -> string + member ResolveSourceFile : range * filename: string * pathLoadedFrom: string -> string + /// File system query based on TcConfig settings member MakePathAbsolute : string -> string @@ -525,7 +526,7 @@ type TcConfig = [] type TcConfigProvider = - member Get : unit -> TcConfig + member Get : CompilationThreadToken -> TcConfig /// Get a TcConfigProvider which will return only the exact TcConfig. static member Constant : TcConfig -> TcConfigProvider @@ -569,8 +570,8 @@ type ImportedAssembly = type TcAssemblyResolutions = member GetAssemblyResolutions : unit -> AssemblyResolution list - static member SplitNonFoundationalResolutions : TcConfig -> AssemblyResolution list * AssemblyResolution list * UnresolvedAssemblyReference list - static member BuildFromPriorResolutions : TcConfig * AssemblyResolution list * UnresolvedAssemblyReference list -> TcAssemblyResolutions + static member SplitNonFoundationalResolutions : CompilationThreadToken * TcConfig -> AssemblyResolution list * AssemblyResolution list * UnresolvedAssemblyReference list + static member BuildFromPriorResolutions : CompilationThreadToken * TcConfig * AssemblyResolution list * UnresolvedAssemblyReference list -> TcAssemblyResolutions @@ -584,32 +585,32 @@ type TcImports = member GetCcusInDeclOrder : unit -> CcuThunk list /// This excludes any framework imports (which may be shared between multiple builds) member GetCcusExcludingBase : unit -> CcuThunk list - member FindDllInfo : range * string -> ImportedBinary - member TryFindDllInfo : range * string * lookupOnly: bool -> option - member FindCcuFromAssemblyRef : range * ILAssemblyRef -> CcuResolutionResult + member FindDllInfo : CompilationThreadToken * range * string -> ImportedBinary + member TryFindDllInfo : CompilationThreadToken * range * string * lookupOnly: bool -> option + member FindCcuFromAssemblyRef : CompilationThreadToken * range * ILAssemblyRef -> CcuResolutionResult #if EXTENSIONTYPING member ProviderGeneratedTypeRoots : ProviderGeneratedType list #endif member GetImportMap : unit -> Import.ImportMap /// Try to resolve a referenced assembly based on TcConfig settings. - member TryResolveAssemblyReference : AssemblyReference * ResolveAssemblyReferenceMode -> OperationResult + member TryResolveAssemblyReference : CompilationThreadToken * AssemblyReference * ResolveAssemblyReferenceMode -> OperationResult /// Resolve a referenced assembly and report an error if the resolution fails. - member ResolveAssemblyReference : AssemblyReference * ResolveAssemblyReferenceMode -> AssemblyResolution list + member ResolveAssemblyReference : CompilationThreadToken * AssemblyReference * ResolveAssemblyReferenceMode -> AssemblyResolution list /// Try to find the given assembly reference. member TryFindExistingFullyQualifiedPathFromAssemblyRef : ILAssemblyRef -> string option #if EXTENSIONTYPING /// Try to find a provider-generated assembly - member TryFindProviderGeneratedAssemblyByName : assemblyName:string -> System.Reflection.Assembly option + member TryFindProviderGeneratedAssemblyByName : CompilationThreadToken * assemblyName:string -> System.Reflection.Assembly option #endif /// Report unresolved references that also weren't consumed by any type providers. member ReportUnresolvedAssemblyReferences : UnresolvedAssemblyReference list -> unit member SystemRuntimeContainsType : string -> bool - static member BuildFrameworkTcImports : TcConfigProvider * AssemblyResolution list * AssemblyResolution list -> TcGlobals * TcImports - static member BuildNonFrameworkTcImports : TcConfigProvider * TcGlobals * TcImports * AssemblyResolution list * UnresolvedAssemblyReference list -> TcImports - static member BuildTcImports : TcConfigProvider -> TcGlobals * TcImports + static member BuildFrameworkTcImports : CompilationThreadToken * TcConfigProvider * AssemblyResolution list * AssemblyResolution list -> TcGlobals * TcImports + static member BuildNonFrameworkTcImports : CompilationThreadToken * TcConfigProvider * TcGlobals * TcImports * AssemblyResolution list * UnresolvedAssemblyReference list -> TcImports + static member BuildTcImports : CompilationThreadToken * TcConfigProvider -> TcGlobals * TcImports //---------------------------------------------------------------------------- // Special resources in DLLs @@ -638,19 +639,19 @@ val WriteOptimizationData : TcGlobals * string * CcuThunk * Optimizer.LazyModul /// Process #r in F# Interactive. /// Adds the reference to the tcImports and add the ccu to the type checking environment. -val RequireDLL : TcImports * TcEnv * thisAssemblyName: string * referenceRange: range * file: string -> TcEnv * (ImportedBinary list * ImportedAssembly list) +val RequireDLL : CompilationThreadToken * TcImports * TcEnv * thisAssemblyName: string * referenceRange: range * file: string -> TcEnv * (ImportedBinary list * ImportedAssembly list) /// Processing # commands val ProcessMetaCommandsFromInput : - ('T -> range * string -> 'T) * - ('T -> range * string -> 'T) * - ('T -> range * string -> unit) -> TcConfigBuilder -> Ast.ParsedInput -> string -> 'T -> 'T + (('T -> range * string -> 'T) * ('T -> range * string -> 'T) * ('T -> range * string -> unit)) + -> TcConfigBuilder * Ast.ParsedInput * string * 'T + -> 'T /// Process all the #r, #I etc. in an input -val ApplyMetaCommandsFromInputToTcConfig : TcConfig -> (Ast.ParsedInput * string) -> TcConfig +val ApplyMetaCommandsFromInputToTcConfig : TcConfig * Ast.ParsedInput * string -> TcConfig /// Process the #nowarn in an input -val ApplyNoWarnsToTcConfig : TcConfig -> (Ast.ParsedInput * string) -> TcConfig +val ApplyNoWarnsToTcConfig : TcConfig * Ast.ParsedInput * string -> TcConfig //---------------------------------------------------------------------------- // Scoped pragmas @@ -704,7 +705,7 @@ val GetInitialTcState : /// Check one input, returned as an Eventually computation val TypeCheckOneInputEventually : - (unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * NameResolution.TcResultsSink * TcState * Ast.ParsedInput + checkForErrors:(unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * NameResolution.TcResultsSink * TcState * Ast.ParsedInput -> Eventually<(TcEnv * TopAttribs * TypedImplFile list) * TcState> /// Finish the checking of multiple inputs @@ -714,11 +715,11 @@ val TypeCheckMultipleInputsFinish : (TcEnv * TopAttribs * 'T list) list * TcStat val TypeCheckClosedInputSetFinish : TypedImplFile list * TcState -> TcState * TypedImplFile list /// Check a closed set of inputs -val TypeCheckClosedInputSet :(unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * TcState * Ast.ParsedInput list -> TcState * TopAttribs * TypedImplFile list * TcEnv +val TypeCheckClosedInputSet : CompilationThreadToken * checkForErrors: (unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * TcState * Ast.ParsedInput list -> TcState * TopAttribs * TypedImplFile list * TcEnv /// Check a single input and finish the checking val TypeCheckOneInputAndFinishEventually : - (unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * NameResolution.TcResultsSink * TcState * Ast.ParsedInput + checkForErrors: (unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * NameResolution.TcResultsSink * TcState * Ast.ParsedInput -> Eventually<(TcEnv * TopAttribs * TypedImplFile list) * TcState> /// Indicates if we should report a warning @@ -775,7 +776,7 @@ type LoadClosure = LoadClosureRootFileDiagnostics : (PhasedDiagnostic * bool) list } // Used from service.fs, when editing a script file - static member ComputeClosureOfSourceText : referenceResolver: ReferenceResolver.Resolver * filename: string * source: string * implicitDefines:CodeContext * useSimpleResolution: bool * useFsiAuxLib: bool * lexResourceManager: Lexhelp.LexResourceManager * applyCompilerOptions: (TcConfigBuilder -> unit) * assumeDotNetFramework : bool -> LoadClosure + static member ComputeClosureOfSourceText : CompilationThreadToken * referenceResolver: ReferenceResolver.Resolver * filename: string * source: string * implicitDefines:CodeContext * useSimpleResolution: bool * useFsiAuxLib: bool * lexResourceManager: Lexhelp.LexResourceManager * applyCompilerOptions: (TcConfigBuilder -> unit) * assumeDotNetFramework : bool -> LoadClosure /// Used from fsi.fs and fsc.fs, for #load and command line. The resulting references are then added to a TcConfig. - static member ComputeClosureOfSourceFiles : tcConfig:TcConfig * (string * range) list * implicitDefines:CodeContext * lexResourceManager : Lexhelp.LexResourceManager -> LoadClosure + static member ComputeClosureOfSourceFiles : CompilationThreadToken * tcConfig:TcConfig * (string * range) list * implicitDefines:CodeContext * lexResourceManager : Lexhelp.LexResourceManager -> LoadClosure diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index dba92ec177..56931edb8f 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -204,7 +204,7 @@ module ResponseFile = let ParseCompilerOptions (collectOtherArgument : string -> unit, blocks: CompilerOptionBlock list, args) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parameter) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter let specs = List.collect GetOptionsOfBlock blocks @@ -355,7 +355,7 @@ let ParseCompilerOptions (collectOtherArgument : string -> unit, blocks: Compile reportDeprecatedOption d let al = getOptionArgList compilerOption argString if al <> [] then - List.iter (fun s -> f s) (getOptionArgList compilerOption argString) + List.iter f (getOptionArgList compilerOption argString) t | (CompilerOption(s, _, OptionStringListSwitch f, d, _) as compilerOption :: _) when getSwitchOpt(optToken) = s -> reportDeprecatedOption d @@ -567,7 +567,7 @@ let errorsAndWarningsFlags (tcConfigB : TcConfigBuilder) = else error(Error(FSComp.SR.optsInvalidWarningLevel(n),rangeCmdArgs))), None, Some (FSComp.SR.optsWarn())); - CompilerOption("nowarn", tagWarnList, OptionStringList (fun n -> tcConfigB.TurnWarningOff(rangeCmdArgs,n)), None, + CompilerOption("nowarn", tagWarnList, OptionStringList (fun n -> tcConfigB.TurnWarningOff(rangeCmdArgs, n)), None, Some (FSComp.SR.optsNowarn())); CompilerOption("warnon", tagWarnList, OptionStringList (fun n -> tcConfigB.TurnWarningOn(rangeCmdArgs,n)), None, @@ -1333,12 +1333,12 @@ let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcCon // by the same references. Only used for static linking. //---------------------------------------------------------------------------- -let NormalizeAssemblyRefs (tcImports:TcImports) scoref = +let NormalizeAssemblyRefs (ctok, tcImports:TcImports) scoref = match scoref with | ILScopeRef.Local | ILScopeRef.Module _ -> scoref | ILScopeRef.Assembly aref -> - match tcImports.TryFindDllInfo (Range.rangeStartup,aref.Name,lookupOnly=false) with + match tcImports.TryFindDllInfo (ctok, Range.rangeStartup, aref.Name, lookupOnly=false) with | Some dllInfo -> dllInfo.ILScopeRef | None -> scoref diff --git a/src/fsharp/CompileOptions.fsi b/src/fsharp/CompileOptions.fsi index 0bb9288ec5..bfd374a38e 100644 --- a/src/fsharp/CompileOptions.fsi +++ b/src/fsharp/CompileOptions.fsi @@ -7,6 +7,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Ast @@ -58,7 +59,6 @@ val FilterCompilerOptionBlock : (CompilerOption -> bool) -> CompilerOptionBlock /// Parse and process a set of compiler options val ParseCompilerOptions : (string -> unit) * CompilerOptionBlock list * string list -> unit - //---------------------------------------------------------------------------- // Compiler Options //-------------------------------------------------------------------------- @@ -87,7 +87,7 @@ val CreateIlxAssemblyGenerator : TcConfig * TcImports * TcGlobals * ConstraintSo val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator -> IlxGen.IlxGenResults // Used during static linking -val NormalizeAssemblyRefs : TcImports -> (AbstractIL.IL.ILScopeRef -> AbstractIL.IL.ILScopeRef) +val NormalizeAssemblyRefs : CompilationThreadToken * TcImports -> (AbstractIL.IL.ILScopeRef -> AbstractIL.IL.ILScopeRef) // Miscellany val ignoreFailureOnMono1_1_16 : (unit -> unit) -> unit @@ -97,4 +97,3 @@ val DoWithErrorColor : bool -> (unit -> 'a) -> 'a val ReportTime : TcConfig -> string -> unit val GetAbbrevFlagSet : TcConfigBuilder -> bool -> Set val PostProcessCompilerArgs : string Set -> string [] -> string list -val ParseCompilerOptions : (string -> unit) * CompilerOptionBlock list * string list -> unit diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index 3c79aaabf2..2044550ce0 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -6,6 +6,7 @@ module internal Microsoft.FSharp.Compiler.ErrorLogger open Internal.Utilities open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Range open System @@ -123,6 +124,7 @@ let rec AttachRange m (exn:exn) = | :? System.ArgumentException as exn -> InternalError(exn.Message + " (ArgumentException)",m) | notARangeDual -> notARangeDual + //---------------------------------------------------------------------------- // Error logger interface @@ -394,7 +396,9 @@ module ErrorLoggerExtensions = /// NOTE: The change will be undone when the returned "unwind" object disposes let PushThreadBuildPhaseUntilUnwind (phase:BuildPhase) = let oldBuildPhase = CompileThreadStatic.BuildPhaseUnchecked + CompileThreadStatic.BuildPhase <- phase + { new System.IDisposable with member x.Dispose() = CompileThreadStatic.BuildPhase <- oldBuildPhase (* maybe null *) } @@ -407,7 +411,9 @@ let PushErrorLoggerPhaseUntilUnwind(errorLoggerTransformer : ErrorLogger -> #Err let chkErrorLogger = { new ErrorLogger("PushErrorLoggerPhaseUntilUnwind") with member x.DiagnosticSink(phasedError, isError) = newIsInstalled(); newErrorLogger.DiagnosticSink(phasedError, isError) member x.ErrorCount = newIsInstalled(); newErrorLogger.ErrorCount } + CompileThreadStatic.ErrorLogger <- chkErrorLogger + { new System.IDisposable with member x.Dispose() = CompileThreadStatic.ErrorLogger <- oldErrorLogger diff --git a/src/fsharp/ExtensionTyping.fsi b/src/fsharp/ExtensionTyping.fsi index 5b3f905f99..bf3d0c7922 100755 --- a/src/fsharp/ExtensionTyping.fsi +++ b/src/fsharp/ExtensionTyping.fsi @@ -13,6 +13,7 @@ module internal ExtensionTyping = open System.Collections.Generic open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Compiler.AbstractIL.IL + open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.Range type TypeProviderDesignation = TypeProviderDesignation of string diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 2f0286d1b7..c9a5e3b2a4 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -6789,7 +6789,7 @@ type IlxGenResults = let GenerateCode (cenv, eenv, TypedAssemblyAfterOptimization fileImpls, assemAttribs, moduleAttribs) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.IlxGen) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.IlxGen // Generate the implementations into the mgbuf let mgbuf= new AssemblyBuilder(cenv) diff --git a/src/fsharp/InternalCollections.fs b/src/fsharp/InternalCollections.fs index 612011cad8..da204620e2 100755 --- a/src/fsharp/InternalCollections.fs +++ b/src/fsharp/InternalCollections.fs @@ -13,11 +13,11 @@ type internal ValueStrength<'T when 'T : not struct> = | Weak of WeakReference<'T> #endif -type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:int, areSame, ?requiredToKeep, ?onStrongDiscard, ?keepMax: int) = +type internal AgedLookup<'Token, 'Key, 'Value when 'Value : not struct>(keepStrongly:int, areSame, ?requiredToKeep, ?onStrongDiscard, ?keepMax: int) = /// The list of items stored. Youngest is at the end of the list. /// The choice of order is somewhat arbitrary. If the other way then adding /// items would be O(1) and removing O(N). - let mutable refs:('TKey*ValueStrength<'TValue>) list = [] + let mutable refs:('Key*ValueStrength<'Value>) list = [] let mutable keepStrongly = keepStrongly // Only set a strong discard function if keepMax is explicitly set to keepStrongly, i.e. there are no weak entries in this lookup. @@ -68,7 +68,8 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i | None -> None,data /// Remove weak entries from the list that have been collected. - let FilterAndHold() = + let FilterAndHold(tok: 'Token) = + ignore tok // reading 'refs' requires a token [ for (key,value) in refs do match value with | Strong(value) -> yield (key,value) @@ -76,14 +77,14 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i #if FX_NO_GENERIC_WEAKREFERENCE match weakReference.Target with | null -> assert onStrongDiscard.IsNone; () - | value -> yield key,(value:?>'TValue) ] + | value -> yield key,(value:?>'Value) ] #else match weakReference.TryGetTarget () with | false, _ -> assert onStrongDiscard.IsNone; () | true, value -> yield key, value ] #endif - let AssignWithStrength(newdata,discard1) = + let AssignWithStrength(tok,newdata,discard1) = let actualLength = List.length newdata let tossThreshold = max 0 (actualLength - keepMax) // Delete everything less than this threshold let weakThreshhold = max 0 (actualLength - keepStrongly) // Weaken everything less than this threshold @@ -104,53 +105,56 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i else Strong(v) k,handle ) + ignore tok // Updating refs requires tok refs <- newdata discard1 |> List.iter (snd >> strongDiscard) discard2 |> List.iter (snd >> snd >> strongDiscard) - member al.TryPeekKeyValue(key) = + member al.TryPeekKeyValue(tok, key) = // Returns the original key value as well since it may be different depending on equality test. - let data = FilterAndHold() + let data = FilterAndHold(tok) TryPeekKeyValueImpl(data,key) - member al.TryGetKeyValue(key) = - let data = FilterAndHold() + member al.TryGetKeyValue(tok, key) = + let data = FilterAndHold(tok) let result,newdata = TryGetKeyValueImpl(data,key) - AssignWithStrength(newdata,[]) + AssignWithStrength(tok,newdata,[]) result - member al.TryGet(key) = - let data = FilterAndHold() + + member al.TryGet(tok, key) = + let data = FilterAndHold(tok) let result,newdata = TryGetKeyValueImpl(data,key) - AssignWithStrength(newdata,[]) + AssignWithStrength(tok,newdata,[]) match result with | Some(_,value) -> Some(value) | None -> None - member al.Put(key,value) = - let data = FilterAndHold() + + member al.Put(tok, key,value) = + let data = FilterAndHold(tok) let data,discard = if Exists(data,key) then RemoveImpl (data,key) else data,[] let data = Add(data,key,value) - AssignWithStrength(data,discard) // This will remove extras + AssignWithStrength(tok,data,discard) // This will remove extras - member al.Remove(key) = - let data = FilterAndHold() + member al.Remove(tok, key) = + let data = FilterAndHold(tok) let newdata,discard = RemoveImpl (data,key) - AssignWithStrength(newdata,discard) + AssignWithStrength(tok,newdata,discard) - member al.Clear() = - let discards = FilterAndHold() - AssignWithStrength([], discards) + member al.Clear(tok) = + let discards = FilterAndHold(tok) + AssignWithStrength(tok,[], discards) - member al.Resize(newKeepStrongly, ?newKeepMax) = + member al.Resize(tok, newKeepStrongly, ?newKeepMax) = let newKeepMax = defaultArg newKeepMax 75 keepStrongly <- newKeepStrongly keepMax <- max newKeepStrongly newKeepMax do assert (onStrongDiscard.IsNone || keepStrongly = keepMax) - let keep = FilterAndHold() - AssignWithStrength(keep, []) + let keep = FilterAndHold(tok) + AssignWithStrength(tok,keep, []) -type internal MruCache<'TKey,'TValue when 'TValue : not struct>(keepStrongly, areSame, ?isStillValid : 'TKey*'TValue->bool, ?areSameForSubsumption, ?requiredToKeep, ?onStrongDiscard, ?keepMax) = +type internal MruCache<'Token, 'Key,'Value when 'Value : not struct>(keepStrongly, areSame, ?isStillValid : 'Key*'Value->bool, ?areSameForSubsumption, ?requiredToKeep, ?onStrongDiscard, ?keepMax) = /// Default behavior of areSameForSubsumption function is areSame. let areSameForSubsumption = defaultArg areSameForSubsumption areSame @@ -158,46 +162,46 @@ type internal MruCache<'TKey,'TValue when 'TValue : not struct>(keepStrongly, ar /// The list of items in the cache. Youngest is at the end of the list. /// The choice of order is somewhat arbitrary. If the other way then adding /// items would be O(1) and removing O(N). - let cache = AgedLookup<'TKey,'TValue>(keepStrongly=keepStrongly,areSame=areSameForSubsumption,?onStrongDiscard=onStrongDiscard,?keepMax=keepMax,?requiredToKeep=requiredToKeep) + let cache = AgedLookup<'Token, 'Key,'Value>(keepStrongly=keepStrongly,areSame=areSameForSubsumption,?onStrongDiscard=onStrongDiscard,?keepMax=keepMax,?requiredToKeep=requiredToKeep) /// Whether or not this result value is still valid. let isStillValid = defaultArg isStillValid (fun _ -> true) - member bc.TryGetAny(key) = - match cache.TryPeekKeyValue(key) with + member bc.TryGetAny(tok, key) = + match cache.TryPeekKeyValue(tok, key) with | Some(key', value)-> if areSame(key',key) then Some(value) else None | None -> None - member bc.TryGet(key) = - match cache.TryGetKeyValue(key) with + member bc.TryGet(tok, key) = + match cache.TryGetKeyValue(tok, key) with | Some(key', value) -> if areSame(key', key) && isStillValid(key,value) then Some value else None | None -> None - member bc.Set(key:'TKey,value:'TValue) = - cache.Put(key,value) + member bc.Set(tok, key:'Key,value:'Value) = + cache.Put(tok, key,value) - member bc.Remove(key) = - cache.Remove(key) + member bc.Remove(tok, key) = + cache.Remove(tok, key) - member bc.Clear() = - cache.Clear() + member bc.Clear(tok) = + cache.Clear(tok) - member bc.Resize(newKeepStrongly, ?newKeepMax) = - cache.Resize(newKeepStrongly, ?newKeepMax=newKeepMax) + member bc.Resize(tok, newKeepStrongly, ?newKeepMax) = + cache.Resize(tok, newKeepStrongly, ?newKeepMax=newKeepMax) /// List helpers [] type internal List = - /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. - /// The original order of the first instance of 'TKey is preserved. - static member groupByFirst( l : ('TKey * 'TValue) list) : ('TKey * 'TValue list) list = + /// Return a new list with one element for each unique 'Key. Multiple 'TValues are flattened. + /// The original order of the first instance of 'Key is preserved. + static member groupByFirst( l : ('Key * 'Value) list) : ('Key * 'Value list) list = let nextIndex = ref 0 - let result = System.Collections.Generic.List<'TKey * System.Collections.Generic.List<'TValue>>() - let keyToIndex = Dictionary<'TKey,int>(HashIdentity.Structural) + let result = System.Collections.Generic.List<'Key * System.Collections.Generic.List<'Value>>() + let keyToIndex = Dictionary<'Key,int>(HashIdentity.Structural) let indexOfKey(key) = match keyToIndex.TryGetValue(key) with | true, v -> v @@ -209,7 +213,7 @@ type internal List = for kv in l do let index = indexOfKey(fst kv) if index>= result.Count then - let k,vs = fst kv,System.Collections.Generic.List<'TValue>() + let k,vs = fst kv,System.Collections.Generic.List<'Value>() vs.Add(snd kv) result.Add(k,vs) else diff --git a/src/fsharp/InternalCollections.fsi b/src/fsharp/InternalCollections.fsi index 77b3c4fb40..88abdc302c 100755 --- a/src/fsharp/InternalCollections.fsi +++ b/src/fsharp/InternalCollections.fsi @@ -5,62 +5,67 @@ namespace Internal.Utilities.Collections /// Simple aging lookup table. When a member is accessed it's /// moved to the top of the list and when there are too many elements /// the least-recently-accessed element falls of the end. - type internal AgedLookup<'TKey,'TValue when 'TValue : not struct> = + type internal AgedLookup<'Token, 'Key, 'Value when 'Value : not struct> = new : keepStrongly:int - * areSame:('TKey * 'TKey -> bool) - * ?requiredToKeep:('TValue -> bool) - * ?onStrongDiscard : ('TValue -> unit) // this may only be set if keepTotal=keepStrongly, i.e. not weak entries + * areSame:('Key * 'Key -> bool) + * ?requiredToKeep:('Value -> bool) + * ?onStrongDiscard : ('Value -> unit) // this may only be set if keepTotal=keepStrongly, i.e. not weak entries * ?keepMax: int - -> AgedLookup<'TKey,'TValue> + -> AgedLookup<'Token,'Key,'Value> /// Lookup the value without making it the most recent. /// Returns the original key value because the areSame function /// may have unified two different keys. - member TryPeekKeyValue : key:'TKey -> ('TKey*'TValue) option + member TryPeekKeyValue : 'Token * key:'Key -> ('Key*'Value) option /// Lookup a value and make it the most recent. /// Returns the original key value because the areSame function /// may have unified two different keys. - member TryGetKeyValue : key:'TKey -> ('TKey*'TValue) option + member TryGetKeyValue : 'Token * key: 'Key -> ('Key*'Value) option /// Lookup a value and make it the most recent. Return None if it wasn't there. - member TryGet : key:'TKey -> 'TValue option + member TryGet : 'Token * key:'Key -> 'Value option /// Add an element to the collection. Make it the most recent. - member Put : 'TKey*'TValue -> unit + member Put : 'Token * 'Key * 'Value -> unit /// Remove the given value from the collection. - member Remove : key:'TKey -> unit + member Remove : 'Token * key:'Key -> unit /// Remove all elements. - member Clear : unit -> unit + member Clear : 'Token -> unit /// Resize - member Resize : keepStrongly: int * ?keepMax : int -> unit + member Resize : 'Token * keepStrongly: int * ?keepMax : int -> unit /// Simple priority caching for a small number of key/value associations. /// This cache may age-out results that have been Set by the caller. /// Because of this, the caller must be able to tolerate values - /// that aren't what was originally passed to the Set function. - type internal MruCache<'TKey,'TValue when 'TValue : not struct> = + /// that aren't what was originally passed to the Set function. + /// + /// Concurrency: This collection is thread-safe, though concurrent use may result in different + /// threads seeing different live sets of cached items, and may result in the onDiscard action + /// being called multiple times. In practice this means the collection is only safe for concurrent + /// access if there is no discard action to execute. + type internal MruCache<'Token, 'Key,'Value when 'Value : not struct> = new : keepStrongly:int - * areSame:('TKey * 'TKey -> bool) - * ?isStillValid:('TKey * 'TValue -> bool) - * ?areSameForSubsumption:('TKey * 'TKey -> bool) - * ?requiredToKeep:('TValue -> bool) - * ?onDiscard:('TValue -> unit) + * areSame:('Key * 'Key -> bool) + * ?isStillValid:('Key * 'Value -> bool) + * ?areSameForSubsumption:('Key * 'Key -> bool) + * ?requiredToKeep:('Value -> bool) + * ?onDiscard:('Value -> unit) * ?keepMax:int - -> MruCache<'TKey,'TValue> + -> MruCache<'Token,'Key,'Value> /// Clear out the cache. - member Clear : unit -> unit + member Clear : 'Token -> unit /// Get the value for the given key or None if not already available. - member TryGetAny : key:'TKey -> 'TValue option + member TryGetAny : 'Token * key:'Key -> 'Value option /// Get the value for the given key or None if not already available - member TryGet : key:'TKey -> 'TValue option + member TryGet : 'Token * key:'Key -> 'Value option /// Remove the given value from the mru cache. - member Remove : key:'TKey -> unit + member Remove : 'Token * key:'Key -> unit /// Set the given key. - member Set : key:'TKey * value:'TValue -> unit + member Set : 'Token * key:'Key * value:'Value -> unit /// Resize - member Resize : keepStrongly: int * ?keepMax : int -> unit + member Resize : 'Token * keepStrongly: int * ?keepMax : int -> unit [] type internal List = - /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. - /// The original order of the first instance of 'TKey is preserved. - static member groupByFirst : l:('TKey * 'TValue) list -> ('TKey * 'TValue list) list when 'TKey : equality + /// Return a new list with one element for each unique 'Key. Multiple 'TValues are flattened. + /// The original order of the first instance of 'Key is preserved. + static member groupByFirst : l:('Key * 'Value) list -> ('Key * 'Value list) list when 'Key : equality /// Return each distinct item in the list using reference equality. static member referenceDistinct : 'T list -> 'T list when 'T : not struct diff --git a/src/fsharp/MSBuildReferenceResolver.fs b/src/fsharp/MSBuildReferenceResolver.fs index 8351ee5c4b..e85ea1f345 100644 --- a/src/fsharp/MSBuildReferenceResolver.fs +++ b/src/fsharp/MSBuildReferenceResolver.fs @@ -214,7 +214,7 @@ module internal Microsoft.FSharp.Compiler.MSBuildReferenceResolver lineIfExists resolvedPath + lineIfExists fusionName - /// Perform assembly resolution by instantiating the ResolveAssemblyReference task directly from the MSBuild SDK. + /// Perform assembly resolution by instantiating the ResolveAssembly task directly from the MSBuild SDK. let ResolveCore(resolutionEnvironment: ResolutionEnvironment, references:(string*(*baggage*)string)[], targetFrameworkVersion: string, diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index d8dcb455ea..e9e886d0af 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -905,7 +905,12 @@ and IsILTypeRefStaticLinkLocal cenv m (tr:ILTypeRef) = | ILScopeRef.Assembly aref when not cenv.g.isInteractive && aref.Name <> cenv.g.ilg.primaryAssemblyName && // optimization to avoid this check in the common case - (match cenv.amap.assemblyLoader.LoadAssembly (m,aref) with + + // Explanation: This represents an unchecked invariant in the hosted compiler: that any operations + // which import types (and resolve assemblies from the tcImports tables) happen on the compilation thread. + let ctok = AssumeCompilationThreadWithoutEvidence() + + (match cenv.amap.assemblyLoader.FindCcuFromAssemblyRef (ctok, m,aref) with | ResolvedCcu ccu -> ccu.IsProviderGenerated | UnresolvedCcu _ -> false) -> true diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 91998e49cc..767ff5b056 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -14539,6 +14539,8 @@ module EstablishTypeDefinitionCores = /// Check and establish a 'type X = ABC<...>' provided type definition let private TcTyconDefnCore_Phase1C_EstablishDeclarationForGeneratedSetOfTypes cenv inSig (tycon:Tycon, rhsType:SynType, tcrefForContainer:TyconRef, theRootType:Tainted, checkTypeName, args, m) = + // Explanation: We are definitely on the compilation thread here, we just have not propagated the token this far. + let ctok = AssumeCompilationThreadWithoutEvidence() let tcref = mkLocalTyconRef tycon try @@ -14564,7 +14566,9 @@ module EstablishTypeDefinitionCores = let isRootGenerated,rootProvAssemStaticLinkInfoOpt = let stRootAssembly = theRootTypeWithRemapping.PApply((fun st -> st.Assembly),m) - cenv.amap.assemblyLoader.GetProvidedAssemblyInfo (m, stRootAssembly) + + cenv.amap.assemblyLoader.GetProvidedAssemblyInfo (ctok, m, stRootAssembly) + let isRootGenerated = isRootGenerated || theRootTypeWithRemapping.PUntaint((fun st -> not st.IsErased),m) if not isRootGenerated then @@ -14594,7 +14598,6 @@ module EstablishTypeDefinitionCores = let ilTgtRootTyRef = tycon.CompiledRepresentationForNamedType theRootTypeWithRemapping.PUntaint ((fun st -> ignore(lookupILTypeRef.Remove(st.RawSystemType)) ; lookupILTypeRef.Add(st.RawSystemType, ilTgtRootTyRef)), m) - // Iterate all nested types and force their embedding, to populate the mapping from System.Type --> TyconRef/ILTypeRef. // This is only needed for generated types, because for other types the System.Type objects self-describe // their corresponding F# type. @@ -14603,7 +14606,7 @@ module EstablishTypeDefinitionCores = // Check the type is a generated type let isGenerated,provAssemStaticLinkInfoOpt = let stAssembly = st.PApply((fun st -> st.Assembly),m) - cenv.amap.assemblyLoader.GetProvidedAssemblyInfo (m, stAssembly) + cenv.amap.assemblyLoader.GetProvidedAssemblyInfo (ctok, m, stAssembly) let isGenerated = isGenerated || st.PUntaint((fun st -> not st.IsErased),m) diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index e231f41eff..ad60c302d5 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -2203,30 +2203,46 @@ module LexbufLocalXmlDocStore = /// Generates compiler-generated names. Each name generated also includes the StartLine number of the range passed in /// at the point of first generation. +/// +/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. +/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs, and it is good +/// policy to make all globally-allocated objects concurrency safe in case future versions of the compiler +/// are used to host mutiple concurrent instances of compilation. type NiceNameGenerator() = + let lockObj = obj() let basicNameCounts = new Dictionary(100) member x.FreshCompilerGeneratedName (name,m:range) = + lock lockObj (fun () -> let basicName = GetBasicNameOfPossibleCompilerGeneratedName name let n = (if basicNameCounts.ContainsKey basicName then basicNameCounts.[basicName] else 0) let nm = CompilerGeneratedNameSuffix basicName (string m.StartLine + (match n with 0 -> "" | n -> "-" + string n)) basicNameCounts.[basicName] <- n+1 - nm + nm) - member x.Reset () = basicNameCounts.Clear() + member x.Reset () = + lock lockObj (fun () -> + basicNameCounts.Clear() + ) /// Generates compiler-generated names marked up with a source code location, but if given the same unique value then /// return precisely the same name. Each name generated also includes the StartLine number of the range passed in /// at the point of first generation. +/// +/// This type may be accessed concurrently, though in practice it is only used from the compilation thread. +/// It is made concurrency-safe since a global instance of the type is allocated in tast.fs. type StableNiceNameGenerator() = + let lockObj = obj() + let names = new Dictionary<(string * int64),string>(100) let basicNameCounts = new Dictionary(100) member x.GetUniqueCompilerGeneratedName (name,m:range,uniq) = + lock lockObj (fun () -> let basicName = GetBasicNameOfPossibleCompilerGeneratedName name if names.ContainsKey (basicName,uniq) then names.[(basicName,uniq)] @@ -2236,12 +2252,13 @@ type StableNiceNameGenerator() = names.[(basicName,uniq)] <- nm basicNameCounts.[basicName] <- n+1 nm + ) member x.Reset () = + lock lockObj (fun () -> basicNameCounts.Clear() names.Clear() - - + ) let rec synExprContainsError inpExpr = let rec walkBind (Binding(_, _, _, _, _, _, _, _, _, synExpr, _, _)) = walkExpr synExpr diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index 5fb6e9bda0..453948dd07 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -177,19 +177,19 @@ type DisposablesTracker() = // TypeCheck, AdjustForScriptCompile //---------------------------------------------------------------------------- -let TypeCheck (tcConfig, tcImports, tcGlobals, errorLogger:ErrorLogger, assemblyName, niceNameGen, tcEnv0, inputs, exiter: Exiter) = +let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, errorLogger:ErrorLogger, assemblyName, niceNameGen, tcEnv0, inputs, exiter: Exiter) = try if isNil inputs then error(Error(FSComp.SR.fscNoImplementationFiles(), Range.rangeStartup)) let ccuName = assemblyName let tcInitialState = GetInitialTcState (rangeStartup, ccuName, tcConfig, tcGlobals, tcImports, niceNameGen, tcEnv0) - TypeCheckClosedInputSet ((fun () -> errorLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, tcInitialState, inputs) + TypeCheckClosedInputSet (ctok, (fun () -> errorLogger.ErrorCount > 0), tcConfig, tcImports, tcGlobals, None, tcInitialState, inputs) with e -> errorRecovery e rangeStartup exiter.Exit 1 /// Check for .fsx and, if present, compute the load closure for of #loaded files. -let AdjustForScriptCompile(tcConfigB:TcConfigBuilder, commandLineSourceFiles, lexResourceManager) = +let AdjustForScriptCompile(ctok, tcConfigB:TcConfigBuilder, commandLineSourceFiles, lexResourceManager) = let combineFilePath file = try @@ -212,12 +212,12 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder, commandLineSourceFiles, le let AppendClosureInformation(filename) = if IsScript filename then - let closure = LoadClosure.ComputeClosureOfSourceFiles(tcConfig, [filename, rangeStartup], CodeContext.Compilation, lexResourceManager=lexResourceManager) + let closure = LoadClosure.ComputeClosureOfSourceFiles(ctok, tcConfig, [filename, rangeStartup], CodeContext.Compilation, lexResourceManager=lexResourceManager) // Record the references from the analysis of the script. The full resolutions are recorded as the corresponding #I paths used to resolve them // are local to the scripts and not added to the tcConfigB (they are added to localized clones of the tcConfigB). let references = closure.References |> List.collect snd |> List.filter (fun r->r.originalReference.Range<>range0 && r.originalReference.Range<>rangeStartup) references |> List.iter (fun r-> tcConfigB.AddReferencedAssemblyByPath(r.originalReference.Range, r.resolvedPath)) - closure.NoWarns |> List.collect (fun (n, ms) -> ms|>List.map(fun m->m, n)) |> List.iter tcConfigB.TurnWarningOff + closure.NoWarns |> List.collect (fun (n, ms) -> ms|>List.map(fun m->m, n)) |> List.iter (fun (x,m) -> tcConfigB.TurnWarningOff(x, m)) closure.SourceFiles |> List.map fst |> List.iter AddIfNotPresent closure.AllRootFileDiagnostics |> List.iter diagnosticSink @@ -840,12 +840,12 @@ module MainModuleBuilder = let CreateMainModule - (tcConfig:TcConfig, tcGlobals, tcImports:TcImports, + (ctok, tcConfig:TcConfig, tcGlobals, tcImports:TcImports, pdbfile, assemblyName, outfile, topAttrs, (iattrs, intfDataResources), optDataResources, codegenResults, assemVerFromAttrib, metadataVersion, secDecls) = - + RequireCompilationThread ctok let ilTypeDefs = //let topTypeDef = mkILTypeDefForGlobalFunctions tcGlobals.ilg (mkILMethods [], emptyILFields) mkILTypeDefs codegenResults.ilTypeDefs @@ -1243,7 +1243,7 @@ module StaticLinker = mutable visited: bool } // Find all IL modules that are to be statically linked given the static linking roots. - let FindDependentILModulesForStaticLinking (tcConfig:TcConfig, tcImports:TcImports, ilxMainModule) = + let FindDependentILModulesForStaticLinking (ctok, tcConfig:TcConfig, tcImports:TcImports, ilxMainModule) = if not tcConfig.standalone && tcConfig.extraStaticLinkRoots.IsEmpty then [] else @@ -1267,10 +1267,10 @@ module StaticLinker = depModuleTable.[ilAssemRef.Name] <- dummyEntry ilAssemRef.Name else if not (depModuleTable.ContainsKey ilAssemRef.Name) then - match tcImports.TryFindDllInfo(Range.rangeStartup, ilAssemRef.Name, lookupOnly=false) with + match tcImports.TryFindDllInfo(ctok, Range.rangeStartup, ilAssemRef.Name, lookupOnly=false) with | Some dllInfo -> let ccu = - match tcImports.FindCcuFromAssemblyRef (Range.rangeStartup, ilAssemRef) with + match tcImports.FindCcuFromAssemblyRef (ctok, Range.rangeStartup, ilAssemRef) with | ResolvedCcu ccu -> Some ccu | UnresolvedCcu(_ccuName) -> None @@ -1332,14 +1332,14 @@ module StaticLinker = yield (n.ccu, n.data) ] // Add all provider-generated assemblies into the static linking set - let FindProviderGeneratedILModules (tcImports:TcImports, providerGeneratedAssemblies: (ImportedBinary * _) list) = + let FindProviderGeneratedILModules (ctok, tcImports:TcImports, providerGeneratedAssemblies: (ImportedBinary * _) list) = [ for (importedBinary, provAssemStaticLinkInfo) in providerGeneratedAssemblies do let ilAssemRef = importedBinary.ILScopeRef.AssemblyRef if debugStaticLinking then printfn "adding provider-generated assembly '%s' into static linking set" ilAssemRef.Name - match tcImports.TryFindDllInfo(Range.rangeStartup, ilAssemRef.Name, lookupOnly=false) with + match tcImports.TryFindDllInfo(ctok, Range.rangeStartup, ilAssemRef.Name, lookupOnly=false) with | Some dllInfo -> let ccu = - match tcImports.FindCcuFromAssemblyRef (Range.rangeStartup, ilAssemRef) with + match tcImports.FindCcuFromAssemblyRef (ctok, Range.rangeStartup, ilAssemRef) with | ResolvedCcu ccu -> Some ccu | UnresolvedCcu(_ccuName) -> None @@ -1350,7 +1350,7 @@ module StaticLinker = // Compute a static linker. This only captures tcImports (a large data structure) if // static linking is enabled. Normally this is not the case, which lets us collect tcImports // prior to this point. - let StaticLink (tcConfig:TcConfig, tcImports:TcImports, ilGlobals:ILGlobals) = + let StaticLink (ctok, tcConfig:TcConfig, tcImports:TcImports, ilGlobals:ILGlobals) = #if EXTENSIONTYPING let providerGeneratedAssemblies = @@ -1375,13 +1375,13 @@ module StaticLinker = (fun ilxMainModule -> ReportTime tcConfig "Find assembly references" - let dependentILModules = FindDependentILModulesForStaticLinking (tcConfig, tcImports, ilxMainModule) + let dependentILModules = FindDependentILModulesForStaticLinking (ctok, tcConfig, tcImports, ilxMainModule) ReportTime tcConfig "Static link" #if EXTENSIONTYPING Morphs.enableMorphCustomAttributeData() - let providerGeneratedILModules = FindProviderGeneratedILModules (tcImports, providerGeneratedAssemblies) + let providerGeneratedILModules = FindProviderGeneratedILModules (ctok, tcImports, providerGeneratedAssemblies) // Transform the ILTypeRefs references in the IL of all provider-generated assemblies so that the references // are now local. @@ -1519,7 +1519,7 @@ module StaticLinker = if (not isMscorlib && name = PrimaryAssembly.Mscorlib.Name) then error (Error(FSComp.SR.fscStaticLinkingNoProfileMismatches(), rangeCmdArgs)) scopeRef - let rewriteAssemblyRefsToMatchLibraries = NormalizeAssemblyRefs tcImports + let rewriteAssemblyRefsToMatchLibraries = NormalizeAssemblyRefs (ctok, tcImports) Morphs.morphILTypeRefsInILModuleMemoized ilGlobals (Morphs.morphILScopeRefsInILTypeRef (validateTargetPlatform >> rewriteExternalRefsToLocalRefs >> rewriteAssemblyRefsToMatchLibraries)) ilxMainModule ilxMainModule) @@ -1633,7 +1633,7 @@ let CopyFSharpCore(outFile: string, referencedDlls: AssemblyReference list) = [] type Args<'T> = Args of 'T -let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = +let main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = // See Bug 735819 let lcidFromCodePage = @@ -1689,7 +1689,7 @@ let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLog try let sourceFiles = let files = ProcessCommandLineFlags (tcConfigB, setProcessThreadLocals, lcidFromCodePage, argv) - AdjustForScriptCompile(tcConfigB, files, lexResourceManager) + AdjustForScriptCompile(ctok, tcConfigB, files, lexResourceManager) sourceFiles with e -> @@ -1704,7 +1704,7 @@ let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLog // Create tcGlobals and frameworkTcImports let outfile, pdbfile, assemblyName = try - tcConfigB.DecideNames sourceFiles + tcConfigB.DecideNames sourceFiles with e -> errorRecovery e rangeStartup delayForFlagsLogger.ForwardDelayedDiagnostics(tcConfigB) @@ -1737,17 +1737,17 @@ let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLog // Resolve assemblies ReportTime tcConfig "Import mscorlib and FSharp.Core.dll" let foundationalTcConfigP = TcConfigProvider.Constant(tcConfig) - let sysRes, otherRes, knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) + let sysRes, otherRes, knownUnresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(ctok, tcConfig) // Import basic assemblies - let tcGlobals, frameworkTcImports = TcImports.BuildFrameworkTcImports (foundationalTcConfigP, sysRes, otherRes) + let tcGlobals, frameworkTcImports = TcImports.BuildFrameworkTcImports (ctok, foundationalTcConfigP, sysRes, otherRes) // Register framework tcImports to be disposed in future disposables.Register frameworkTcImports // Parse sourceFiles ReportTime tcConfig "Parse inputs" - use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse let inputs = try let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint @@ -1770,13 +1770,13 @@ let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLog if tcConfig.printAst then inputs |> List.iter (fun (input, _filename) -> printf "AST:\n"; printfn "%+A" input; printf "\n") - let tcConfig = (tcConfig, inputs) ||> List.fold ApplyMetaCommandsFromInputToTcConfig + let tcConfig = (tcConfig, inputs) ||> List.fold (fun z (x, m) -> ApplyMetaCommandsFromInputToTcConfig(z, x, m)) let tcConfigP = TcConfigProvider.Constant(tcConfig) // Import other assemblies ReportTime tcConfig "Import non-system references" let tcGlobals, tcImports = - let tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP, tcGlobals, frameworkTcImports, otherRes, knownUnresolved) + let tcImports = TcImports.BuildNonFrameworkTcImports(ctok, tcConfigP, tcGlobals, frameworkTcImports, otherRes, knownUnresolved) tcGlobals, tcImports // register tcImports to be disposed in future @@ -1789,24 +1789,24 @@ let main0(argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLog // Build the initial type checking environment ReportTime tcConfig "Typecheck" - use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) + use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck let tcEnv0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) // Type check the inputs let inputs = inputs |> List.map fst let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = - TypeCheck(tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs, exiter) + TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs, exiter) AbortOnError(errorLogger, exiter) ReportTime tcConfig "Typechecked" - Args (tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) -let main1(Args (tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = +let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = if tcConfig.typeCheckOnly then exiter.Exit 0 - use unwindPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.CodeGen) + use unwindPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.CodeGen let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) AbortOnError(errorLogger, exiter) @@ -1832,7 +1832,7 @@ let main1(Args (tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCc // write interface, xmldoc begin ReportTime tcConfig ("Write Interface File") - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Output) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output if tcConfig.printSignature then InterfaceFileWriter.WriteInterfaceFile (tcGlobals, tcConfig, InfoReader(tcGlobals, tcImports.GetImportMap()), typedImplFiles) ReportTime tcConfig ("Write XML document signatures") @@ -1848,11 +1848,11 @@ let main1(Args (tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCc end // Pass on only the minimum information required for the next phase - Args (tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) /// Phase 2a: encode signature data, optimize, encode optimization data -let main2a(Args (tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = +let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = // Encode the signature data ReportTime tcConfig ("Encode Interface Data") @@ -1866,7 +1866,7 @@ let main2a(Args (tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, exiter.Exit 1 // Perform optimization - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Optimize) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Optimize let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) @@ -1884,20 +1884,20 @@ let main2a(Args (tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, let optDataResources = EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData)) // Pass on only the minimum information required for the next phase - Args (tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) + Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) /// Phase 2b: IL code generation -let main2b(Args (tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = +let main2b(Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = // Compute a static linker. let ilGlobals = tcGlobals.ilg if tcConfig.standalone && generatedCcu.UsesFSharp20PlusQuotations then error(Error(FSComp.SR.fscQuotationLiteralsStaticLinking0(), rangeStartup)) - let staticLinker = StaticLinker.StaticLink (tcConfig, tcImports, ilGlobals) + let staticLinker = StaticLinker.StaticLink (ctok, tcConfig, tcImports, ilGlobals) // Generate IL code ReportTime tcConfig "TAST -> IL" - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.IlxGen) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.IlxGen let ilxGenerator = CreateIlxAssemblyGenerator (tcConfig, tcImports, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), generatedCcu) // Check if System.SerializableAttribute exists in mscorlib.dll, @@ -1911,17 +1911,17 @@ let main2b(Args (tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogge let permissionSets = ilxGenerator.CreatePermissionSets securityAttrs let secDecls = if securityAttrs.Length > 0 then mkILSecurityDecls permissionSets else emptyILSecurityDecls - let ilxMainModule = MainModuleBuilder.CreateMainModule (tcConfig, tcGlobals, tcImports, pdbfile, assemblyName, outfile, topAttrs, idata, optDataResources, codegenResults, assemVerFromAttrib, metadataVersion, secDecls) + let ilxMainModule = MainModuleBuilder.CreateMainModule (ctok, tcConfig, tcGlobals, tcImports, pdbfile, assemblyName, outfile, topAttrs, idata, optDataResources, codegenResults, assemVerFromAttrib, metadataVersion, secDecls) AbortOnError(errorLogger, exiter) // Pass on only the minimum information required for the next phase - Args (tcConfig, errorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter) + Args (ctok, tcConfig, errorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter) /// Phase 3: static linking -let main3(Args (tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter:Exiter)) = +let main3(Args (ctok, tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter:Exiter)) = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Output) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output // Static linking, if any let ilxMainModule = @@ -1933,14 +1933,16 @@ let main3(Args (tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, out AbortOnError(errorLogger, exiter) // Pass on only the minimum information required for the next phase - Args (tcConfig, errorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter) + Args (ctok, tcConfig, errorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter) /// Phase 4: write the binaries -let main4 (Args (tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter: Exiter)) = +let main4 (Args (ctok, tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter: Exiter)) = ReportTime tcConfig "Write .NET Binary" - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Output) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Output let outfile = tcConfig.MakePathAbsolute outfile + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + let pdbfile = pdbfile |> Option.map (tcConfig.MakePathAbsolute >> Path.GetFullPath) begin try @@ -1980,10 +1982,14 @@ let main4 (Args (tcConfig, errorLogger: ErrorLogger, ilGlobals, ilxMainModule, o /// Entry point typecheckAndCompile let typecheckAndCompile (argv, referenceResolver, bannerAlreadyPrinted, exiter:Exiter, errorLoggerProvider) = + + // Explanation: Compilation happens on whichever thread calls this function. + let ctok = AssumeCompilationThreadWithoutEvidence () + use d = new DisposablesTracker() use e = new SaveAndRestoreConsoleEncoding() - main0(argv, referenceResolver, bannerAlreadyPrinted, exiter, errorLoggerProvider, d) + main0(ctok, argv, referenceResolver, bannerAlreadyPrinted, exiter, errorLoggerProvider, d) |> main1 |> main2a |> main2b diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi index 300a1cda83..fcd8476438 100755 --- a/src/fsharp/fsc.fsi +++ b/src/fsharp/fsc.fsi @@ -4,6 +4,7 @@ module internal Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.CompileOps diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index 580b80aa0c..11e1155a72 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -285,7 +285,7 @@ type public FsiEvaluationSessionHostConfig () = /// Used to print value signatures along with their values, according to the current /// set of pretty printers installed in the system, and default printing rules. -type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, generateDebugInfo, resolvePath, outWriter: TextWriter) = +type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, generateDebugInfo, resolveAssemblyRef, outWriter: TextWriter) = /// This printer is used by F# Interactive if no other printers apply. let DefaultPrintingIntercept (ienv: Internal.Utilities.StructuredFormat.IEnvironment) (obj:obj) = @@ -357,7 +357,7 @@ type internal FsiValuePrinter(fsi: FsiEvaluationSessionHostConfig, g: TcGlobals, /// Get the evaluation context used when inverting the storage mapping of the ILRuntimeWriter. member __.GetEvaluationContext emEnv = - let cenv = { ilg = g.ilg ; generatePdb = generateDebugInfo; resolvePath=resolvePath; tryFindSysILTypeRef=g.TryFindSysILTypeRef } + let cenv = { ilg = g.ilg ; generatePdb = generateDebugInfo; resolveAssemblyRef=resolveAssemblyRef; tryFindSysILTypeRef=g.TryFindSysILTypeRef } { LookupFieldRef = ILRuntimeWriter.LookupFieldRef emEnv >> Option.get LookupMethodRef = ILRuntimeWriter.LookupMethodRef emEnv >> Option.get LookupTypeRef = ILRuntimeWriter.LookupTypeRef cenv emEnv @@ -956,7 +956,7 @@ type internal FsiDynamicCompiler fsiOptions : FsiCommandLineOptions, fsiConsoleOutput : FsiConsoleOutput, niceNameGen, - resolvePath) = + resolveAssemblyRef) = let outfile = "TMPFSCI.exe" let assemblyName = "FSI-ASSEMBLY" @@ -966,7 +966,7 @@ type internal FsiDynamicCompiler let generateDebugInfo = tcConfigB.debuginfo - let valuePrinter = FsiValuePrinter(fsi, tcGlobals, generateDebugInfo, resolvePath, outWriter) + let valuePrinter = FsiValuePrinter(fsi, tcGlobals, generateDebugInfo, resolveAssemblyRef, outWriter) let assemblyBuilder,moduleBuilder = ILRuntimeWriter.mkDynamicAssemblyAndModule (assemblyName, tcConfigB.optSettings.localOpt(), generateDebugInfo, false) @@ -983,7 +983,7 @@ type internal FsiDynamicCompiler (let man = mainModule.ManifestOfAssembly Some { man with CustomAttrs = mkILCustomAttrs codegenResults.ilAssemAttrs }); } - let ProcessInputs(errorLogger: ErrorLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent) = + let ProcessInputs (ctok, errorLogger: ErrorLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent) = let optEnv = istate.optEnv let emEnv = istate.emEnv let tcState = istate.tcState @@ -993,7 +993,7 @@ type internal FsiDynamicCompiler // Typecheck. The lock stops the type checker running at the same time as the // server intellisense implementation (which is currently incomplete and #if disabled) let (tcState:TcState),topCustomAttrs,declaredImpls,tcEnvAtEndOfLastInput = - lock tcLockObject (fun _ -> TypeCheckClosedInputSet(errorLogger.CheckForErrors,tcConfig,tcImports,tcGlobals, Some prefixPath,tcState,inputs)) + lock tcLockObject (fun _ -> TypeCheckClosedInputSet(ctok, errorLogger.CheckForErrors, tcConfig, tcImports, tcGlobals, Some prefixPath, tcState, inputs)) #if DEBUG // Logging/debugging @@ -1030,7 +1030,7 @@ type internal FsiDynamicCompiler errorLogger.AbortOnError(fsiConsoleOutput); ReportTime tcConfig "Assembly refs Normalised"; - let mainmod3 = Morphs.morphILScopeRefsInILModuleMemoized ilGlobals (NormalizeAssemblyRefs tcImports) ilxMainModule + let mainmod3 = Morphs.morphILScopeRefsInILModuleMemoized ilGlobals (NormalizeAssemblyRefs (ctok, tcImports)) ilxMainModule errorLogger.AbortOnError(fsiConsoleOutput); #if DEBUG @@ -1044,14 +1044,14 @@ type internal FsiDynamicCompiler ReportTime tcConfig "Reflection.Emit"; - let emEnv,execs = ILRuntimeWriter.emitModuleFragment(ilGlobals, emEnv, assemblyBuilder, moduleBuilder, mainmod3, generateDebugInfo, resolvePath, tcGlobals.TryFindSysILTypeRef) + let emEnv,execs = ILRuntimeWriter.emitModuleFragment(ilGlobals, emEnv, assemblyBuilder, moduleBuilder, mainmod3, generateDebugInfo, resolveAssemblyRef, tcGlobals.TryFindSysILTypeRef) errorLogger.AbortOnError(fsiConsoleOutput); // Explicitly register the resources with the QuotationPickler module // We would save them as resources into the dynamic assembly but there is missing // functionality System.Reflection for dynamic modules that means they can't be read back out - let cenv = { ilg = ilGlobals ; generatePdb = generateDebugInfo; resolvePath=resolvePath; tryFindSysILTypeRef=tcGlobals.TryFindSysILTypeRef } + let cenv = { ilg = ilGlobals ; generatePdb = generateDebugInfo; resolveAssemblyRef=resolveAssemblyRef; tryFindSysILTypeRef=tcGlobals.TryFindSysILTypeRef } for (referencedTypeDefs, bytes) in codegenResults.quotationResourceInfo do let referencedTypes = [| for tref in referencedTypeDefs do @@ -1116,23 +1116,23 @@ type internal FsiDynamicCompiler member __.DynamicAssemblyName = assemblyName member __.DynamicAssembly = (assemblyBuilder :> Assembly) - member __.EvalParsedSourceFiles (errorLogger, istate, inputs) = + member __.EvalParsedSourceFiles (ctok, errorLogger, istate, inputs) = let i = nextFragmentId() let prefix = mkFragmentPath i // Ensure the path includes the qualifying name let inputs = inputs |> List.map (PrependPathToInput prefix) - let istate,_,_ = ProcessInputs (errorLogger, istate, inputs, true, false, false, prefix) + let istate,_,_ = ProcessInputs (ctok, errorLogger, istate, inputs, true, false, false, prefix) istate /// Evaluate the given definitions and produce a new interactive state. - member __.EvalParsedDefinitions (errorLogger: ErrorLogger, istate, showTypes, isInteractiveItExpr, defs: SynModuleDecls) = + member __.EvalParsedDefinitions (ctok, errorLogger: ErrorLogger, istate, showTypes, isInteractiveItExpr, defs: SynModuleDecls) = let filename = Lexhelp.stdinMockFilename let i = nextFragmentId() let prefix = mkFragmentPath i let prefixPath = pathOfLid prefix let impl = SynModuleOrNamespace(prefix,(*isRec*)false, (* isModule: *) true,defs,PreXmlDoc.Empty,[],None,rangeStdin) let input = ParsedInput.ImplFile(ParsedImplFileInput(filename,true, ComputeQualifiedNameOfFileFromUniquePath (rangeStdin,prefixPath),[],[],[impl],(true (* isLastCompiland *), false (* isExe *)) )) - let istate,tcEnvAtEndOfLastInput,_declaredImpls = ProcessInputs (errorLogger, istate, [input], showTypes, true, isInteractiveItExpr, prefix) + let istate,tcEnvAtEndOfLastInput,_declaredImpls = ProcessInputs (ctok, errorLogger, istate, [input], showTypes, true, isInteractiveItExpr, prefix) let tcState = istate.tcState let newState = { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) } @@ -1140,7 +1140,7 @@ type internal FsiDynamicCompiler /// Evaluate the given expression and produce a new interactive state. - member fsiDynamicCompiler.EvalParsedExpression (errorLogger: ErrorLogger, istate, expr: SynExpr) = + member fsiDynamicCompiler.EvalParsedExpression (ctok, errorLogger: ErrorLogger, istate, expr: SynExpr) = let tcConfig = TcConfig.Create (tcConfigB, validate=false) let itName = "it" @@ -1148,7 +1148,7 @@ type internal FsiDynamicCompiler let defs = fsiDynamicCompiler.BuildItBinding expr // Evaluate the overall definitions. - let istate = fsiDynamicCompiler.EvalParsedDefinitions (errorLogger, istate, false, true, defs) + let istate = fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, false, true, defs) // Snarf the type for 'it' via the binding match istate.tcState.TcEnvFromImpls.NameEnv.FindUnqualifiedItem itName with | NameResolution.Item.Value vref -> @@ -1197,16 +1197,16 @@ type internal FsiDynamicCompiler let breakStatement = SynExpr.App(ExprAtomicFlag.Atomic, false, methCall, args, m) SynModuleDecl.DoExpr(SequencePointInfoForBinding.NoSequencePointAtDoBinding, breakStatement, m) - member __.EvalRequireReference istate m path = + member __.EvalRequireReference (ctok, istate, m, path) = if FileSystem.IsInvalidPathShim(path) then error(Error(FSIstrings.SR.fsiInvalidAssembly(path),m)) // Check the file can be resolved before calling requireDLLReference - let resolutions = tcImports.ResolveAssemblyReference(AssemblyReference(m,path,None),ResolveAssemblyReferenceMode.ReportErrors) + let resolutions = tcImports.ResolveAssemblyReference(ctok, AssemblyReference(m,path,None), ResolveAssemblyReferenceMode.ReportErrors) tcConfigB.AddReferencedAssemblyByPath(m,path) let tcState = istate.tcState let tcEnv,(_dllinfos,ccuinfos) = try - RequireDLL (tcImports, tcState.TcEnvFromImpls, assemblyName, m, path) + RequireDLL (ctok, tcImports, tcState.TcEnvFromImpls, assemblyName, m, path) with e -> tcConfigB.RemoveReferencedAssemblyByPath(m,path) reraise() @@ -1215,29 +1215,26 @@ type internal FsiDynamicCompiler resolutions, { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnv); optEnv = optEnv } - member fsiDynamicCompiler.ProcessMetaCommandsFromInputAsInteractiveCommands istate sourceFile inp = + member fsiDynamicCompiler.ProcessMetaCommandsFromInputAsInteractiveCommands(ctok, istate, sourceFile, inp) = WithImplicitHome (tcConfigB, directoryName sourceFile) (fun () -> ProcessMetaCommandsFromInput ((fun st (m,nm) -> tcConfigB.TurnWarningOff(m,nm); st), - (fun st (m,nm) -> snd (fsiDynamicCompiler.EvalRequireReference st m nm)), + (fun st (m,nm) -> snd (fsiDynamicCompiler.EvalRequireReference (ctok, st, m, nm))), (fun _ _ -> ())) - tcConfigB - inp - (Path.GetDirectoryName sourceFile) - istate) + (tcConfigB, inp, Path.GetDirectoryName sourceFile, istate)) - member fsiDynamicCompiler.EvalSourceFiles(istate, m, sourceFiles, lexResourceManager, errorLogger: ErrorLogger) = + member fsiDynamicCompiler.EvalSourceFiles(ctok, istate, m, sourceFiles, lexResourceManager, errorLogger: ErrorLogger) = let tcConfig = TcConfig.Create(tcConfigB,validate=false) match sourceFiles with | [] -> istate | _ -> // use a set of source files as though they were command line inputs - let sourceFiles = sourceFiles |> List.map (fun nm -> tcConfig.ResolveSourceFile(m,nm,tcConfig.implicitIncludeDir),m) + let sourceFiles = sourceFiles |> List.map (fun nm -> tcConfig.ResolveSourceFile(m, nm, tcConfig.implicitIncludeDir),m) // Close the #load graph on each file and gather the inputs from the scripts. - let closure = LoadClosure.ComputeClosureOfSourceFiles(TcConfig.Create(tcConfigB,validate=false),sourceFiles,CodeContext.Evaluation,lexResourceManager=lexResourceManager) + let closure = LoadClosure.ComputeClosureOfSourceFiles(ctok, TcConfig.Create(tcConfigB,validate=false), sourceFiles, CodeContext.Evaluation,lexResourceManager=lexResourceManager) // Intent "[Loading %s]\n" (String.concat "\n and " sourceFiles) fsiConsoleOutput.uprintf "[%s " (FSIstrings.SR.fsiLoadingFilesPrefixText()) @@ -1267,8 +1264,8 @@ type internal FsiDynamicCompiler errorLogger.AbortOnError(fsiConsoleOutput); if inputs |> List.exists Option.isNone then failwith "parse error" let inputs = List.map Option.get inputs - let istate = List.fold2 fsiDynamicCompiler.ProcessMetaCommandsFromInputAsInteractiveCommands istate sourceFiles inputs - fsiDynamicCompiler.EvalParsedSourceFiles (errorLogger, istate, inputs) + let istate = (istate, sourceFiles, inputs) |||> List.fold2 (fun istate sourceFile input -> fsiDynamicCompiler.ProcessMetaCommandsFromInputAsInteractiveCommands(ctok, istate, sourceFile, input)) + fsiDynamicCompiler.EvalParsedSourceFiles (ctok, errorLogger, istate, inputs) member __.GetInitialInteractiveState () = @@ -1587,7 +1584,8 @@ module internal MagicAssemblyResolution = { new System.IDisposable with member x.Dispose() = () } #else - let ResolveAssembly(m,tcConfigB, tcImports: TcImports, fsiDynamicCompiler: FsiDynamicCompiler, fsiConsoleOutput: FsiConsoleOutput, fullAssemName:string) = + let ResolveAssembly (ctok, m, tcConfigB, tcImports: TcImports, fsiDynamicCompiler: FsiDynamicCompiler, fsiConsoleOutput: FsiConsoleOutput, fullAssemName:string) = + try // Grab the name of the assembly let tcConfig = TcConfig.Create(tcConfigB,validate=false) @@ -1611,14 +1609,14 @@ module internal MagicAssemblyResolution = let assemblyReferenceTextExe = (simpleAssemName + ".exe") let overallSearchResult = // OK, try to resolve as a .dll - let searchResult = tcImports.TryResolveAssemblyReference (AssemblyReference(m,assemblyReferenceTextDll,None),ResolveAssemblyReferenceMode.Speculative) + let searchResult = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, assemblyReferenceTextDll, None), ResolveAssemblyReferenceMode.Speculative) match searchResult with | OkResult (warns,[r]) -> OkResult (warns, Choice1Of2 r.resolvedPath) | _ -> // OK, try to resolve as a .exe - let searchResult = tcImports.TryResolveAssemblyReference (AssemblyReference(m,assemblyReferenceTextExe,None),ResolveAssemblyReferenceMode.Speculative) + let searchResult = tcImports.TryResolveAssemblyReference (ctok, AssemblyReference (m, assemblyReferenceTextExe, None), ResolveAssemblyReferenceMode.Speculative) match searchResult with | OkResult (warns, [r]) -> OkResult (warns, Choice1Of2 r.resolvedPath) @@ -1632,7 +1630,7 @@ module internal MagicAssemblyResolution = if !progress then fsiConsoleOutput.uprintfn "ATTEMPT MAGIC LOAD ON FILE, referencedDLL = %s" assemblyReference.Text if System.String.Compare(Filename.fileNameOfPath assemblyReference.Text, assemblyReferenceTextDll,StringComparison.OrdinalIgnoreCase) = 0 || System.String.Compare(Filename.fileNameOfPath assemblyReference.Text, assemblyReferenceTextExe,StringComparison.OrdinalIgnoreCase) = 0 then - Some(tcImports.TryResolveAssemblyReference(assemblyReference,ResolveAssemblyReferenceMode.Speculative)) + Some(tcImports.TryResolveAssemblyReference (ctok, assemblyReference, ResolveAssemblyReferenceMode.Speculative)) else None )) match searchResult with @@ -1640,7 +1638,7 @@ module internal MagicAssemblyResolution = | _ -> #if EXTENSIONTYPING - match tcImports.TryFindProviderGeneratedAssemblyByName(simpleAssemName) with + match tcImports.TryFindProviderGeneratedAssemblyByName(ctok, simpleAssemName) with | Some(assembly) -> OkResult([],Choice2Of2 assembly) | None -> #endif @@ -1671,7 +1669,10 @@ module internal MagicAssemblyResolution = let rangeStdin = rangeN Lexhelp.stdinMockFilename 0 let handler = new ResolveEventHandler(fun _ args -> - ResolveAssembly (rangeStdin, tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput, args.Name)) + // Explanation: our understanding is that magic assembly resolution happens + // during compilation. So we recover the CompilationThreadToken here. + let ctok = AssumeCompilationThreadWithoutEvidence () + ResolveAssembly (ctok, rangeStdin, tcConfigB, tcImports, fsiDynamicCompiler, fsiConsoleOutput, args.Name)) AppDomain.CurrentDomain.add_AssemblyResolve(handler) @@ -1788,12 +1789,17 @@ type internal FsiInteractionProcessor let runCodeOnEventLoop errorLogger f istate = try fsi.EventLoopInvoke (fun () -> + + // Explanation: We assume the event loop on the 'fsi' object correctly transfers control to + // a unique compilation thread. + let ctok = AssumeCompilationThreadWithoutEvidence() + // FSI error logging on switched to thread InstallErrorLoggingOnThisThread errorLogger #if FX_LCIDFROMCODEPAGE use _scope = SetCurrentUICultureForThread fsiOptions.FsiLCID #endif - f istate) + f ctok istate) with _ -> (istate,Completed None) @@ -1849,21 +1855,21 @@ type internal FsiInteractionProcessor None /// Execute a single parsed interaction. Called on the GUI/execute/main thread. - let ExecInteraction (tcConfig:TcConfig, istate, action:ParsedFsiInteraction, errorLogger: ErrorLogger) = + let ExecInteraction (ctok, tcConfig:TcConfig, istate, action:ParsedFsiInteraction, errorLogger: ErrorLogger) = istate |> InteractiveCatch errorLogger (fun istate -> match action with | IDefns ([ ],_) -> istate,Completed None | IDefns ([ SynModuleDecl.DoExpr(_,expr,_)],_) -> - fsiDynamicCompiler.EvalParsedExpression(errorLogger, istate, expr) + fsiDynamicCompiler.EvalParsedExpression(ctok, errorLogger, istate, expr) | IDefns (defs,_) -> - fsiDynamicCompiler.EvalParsedDefinitions (errorLogger, istate, true, false, defs),Completed None + fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, true, false, defs),Completed None | IHash (ParsedHashDirective("load",sourceFiles,m),_) -> - fsiDynamicCompiler.EvalSourceFiles (istate, m, sourceFiles, lexResourceManager, errorLogger),Completed None + fsiDynamicCompiler.EvalSourceFiles (ctok, istate, m, sourceFiles, lexResourceManager, errorLogger),Completed None | IHash (ParsedHashDirective(("reference" | "r"),[path],m),_) -> - let resolutions,istate = fsiDynamicCompiler.EvalRequireReference istate m path + let resolutions,istate = fsiDynamicCompiler.EvalRequireReference(ctok, istate, m, path) resolutions |> List.iter (fun ar -> let format = #if FSI_SHADOW_COPY_REFERENCES @@ -1954,7 +1960,7 @@ type internal FsiInteractionProcessor /// /// #directive comes through with other definitions as a SynModuleDecl.HashDirective. /// We split these out for individual processing. - let rec execParsedInteractions (tcConfig, istate, action, errorLogger: ErrorLogger, lastResult:option) = + let rec execParsedInteractions (ctok, tcConfig, istate, action, errorLogger: ErrorLogger, lastResult:option) = let action,nextAction,istate = match action with | None -> None ,None,istate @@ -1999,20 +2005,20 @@ type internal FsiInteractionProcessor | None, Some prev -> assert(nextAction.IsNone); istate, prev | None,_ -> assert(nextAction.IsNone); istate, Completed None | Some action, _ -> - let istate,cont = ExecInteraction (tcConfig, istate, action, errorLogger) + let istate,cont = ExecInteraction (ctok, tcConfig, istate, action, errorLogger) match cont with - | Completed _ -> execParsedInteractions (tcConfig, istate, nextAction, errorLogger, Some cont) + | Completed _ -> execParsedInteractions (ctok, tcConfig, istate, nextAction, errorLogger, Some cont) | CompletedWithReportedError e -> istate,CompletedWithReportedError e (* drop nextAction on error *) | EndOfFile -> istate,defaultArg lastResult (Completed None) (* drop nextAction on EOF *) | CtrlC -> istate,CtrlC (* drop nextAction on CtrlC *) /// Execute a single parsed interaction on the parser/execute thread. - let mainThreadProcessAction action istate = + let mainThreadProcessAction ctok action istate = try let tcConfig = TcConfig.Create(tcConfigB,validate=false) if !progress then fprintfn fsiConsoleOutput.Out "In mainThreadProcessAction..."; fsiInterruptController.InterruptAllowed <- InterruptCanRaiseException; - let res = action tcConfig istate + let res = action ctok tcConfig istate fsiInterruptController.ClearInterruptRequest() fsiInterruptController.InterruptAllowed <- InterruptIgnored; res @@ -2030,9 +2036,9 @@ type internal FsiInteractionProcessor stopProcessingRecovery e range0; istate, CompletedWithReportedError e - let mainThreadProcessParsedInteractions errorLogger (action, istate) = - istate |> mainThreadProcessAction (fun tcConfig istate -> - execParsedInteractions (tcConfig, istate, action, errorLogger, None)) + let mainThreadProcessParsedInteractions ctok errorLogger (action, istate) = + istate |> mainThreadProcessAction ctok (fun ctok tcConfig istate -> + execParsedInteractions (ctok, tcConfig, istate, action, errorLogger, None)) let parseExpression (tokenizer:LexFilter.LexFilter) = reusingLexbufForParsing tokenizer.LexBuffer (fun () -> @@ -2042,10 +2048,10 @@ type internal FsiInteractionProcessor // reusingLexbufForParsing tokenizer.LexBuffer (fun () -> // Parser.typEOF tokenizer.Lexer tokenizer.LexBuffer) - let mainThreadProcessParsedExpression errorLogger (expr, istate) = + let mainThreadProcessParsedExpression ctok errorLogger (expr, istate) = istate |> InteractiveCatch errorLogger (fun istate -> - istate |> mainThreadProcessAction (fun _tcConfig istate -> - fsiDynamicCompiler.EvalParsedExpression(errorLogger, istate, expr) )) + istate |> mainThreadProcessAction ctok (fun ctok _tcConfig istate -> + fsiDynamicCompiler.EvalParsedExpression(ctok, errorLogger, istate, expr) )) let commitResult (istate, result) = match result with @@ -2094,7 +2100,7 @@ type internal FsiInteractionProcessor // After we've unblocked and got something to run we switch // over to the run-thread (e.g. the GUI thread) - let res = istate |> runCodeOnMainThread (fun istate -> mainThreadProcessParsedInteractions errorLogger (action, istate)) + let res = istate |> runCodeOnMainThread (fun ctok istate -> mainThreadProcessParsedInteractions ctok errorLogger (action, istate)) if !progress then fprintfn fsiConsoleOutput.Out "Just called runCodeOnMainThread, res = %O..." res; res) @@ -2102,10 +2108,10 @@ type internal FsiInteractionProcessor member __.CurrentState = currState /// Perform an "include" on a script file (i.e. a script file specified on the command line) - member processor.EvalIncludedScript (istate, sourceFile, m, errorLogger) = + member processor.EvalIncludedScript (ctok, istate, sourceFile, m, errorLogger) = let tcConfig = TcConfig.Create(tcConfigB, validate=false) // Resolve the filename to an absolute filename - let sourceFile = tcConfig.ResolveSourceFile(m,sourceFile,tcConfig.implicitIncludeDir) + let sourceFile = tcConfig.ResolveSourceFile(m, sourceFile, tcConfig.implicitIncludeDir) // During the processing of the file, further filenames are // resolved relative to the home directory of the loaded file. WithImplicitHome (tcConfigB, directoryName sourceFile) (fun () -> @@ -2113,7 +2119,7 @@ type internal FsiInteractionProcessor // We repeatedly parse and process these, until an error occurs. let tokenizer = fsiStdinLexerProvider.CreateIncludedScriptLexer (sourceFile, errorLogger) let rec run istate = - let istate,cont = processor.ParseAndExecOneSetOfInteractionsFromLexbuf ((fun f istate -> f istate), istate, tokenizer, errorLogger) + let istate,cont = processor.ParseAndExecOneSetOfInteractionsFromLexbuf ((fun f istate -> f ctok istate), istate, tokenizer, errorLogger) match cont with Completed _ -> run istate | _ -> istate,cont let istate,cont = run istate @@ -2127,20 +2133,20 @@ type internal FsiInteractionProcessor /// Load the source files, one by one. Called on the main thread. - member processor.EvalIncludedScripts (istate, sourceFiles, errorLogger) = + member processor.EvalIncludedScripts (ctok, istate, sourceFiles, errorLogger) = match sourceFiles with | [] -> istate | sourceFile :: moreSourceFiles -> // Catch errors on a per-file basis, so results/bindings from pre-error files can be kept. - let istate,cont = InteractiveCatch errorLogger (fun istate -> processor.EvalIncludedScript (istate, sourceFile, rangeStdin, errorLogger)) istate + let istate,cont = InteractiveCatch errorLogger (fun istate -> processor.EvalIncludedScript (ctok, istate, sourceFile, rangeStdin, errorLogger)) istate match cont with - | Completed _ -> processor.EvalIncludedScripts (istate, moreSourceFiles, errorLogger) + | Completed _ -> processor.EvalIncludedScripts (ctok, istate, moreSourceFiles, errorLogger) | CompletedWithReportedError _ -> istate // do not process any more files | CtrlC -> istate // do not process any more files | EndOfFile -> assert false; istate // This is unexpected. EndOfFile is replaced by Completed in the called function - member processor.LoadInitialFiles (errorLogger) = + member processor.LoadInitialFiles (ctok, errorLogger) = /// Consume initial source files in chunks of scripts or non-scripts let rec consume istate sourceFiles = match sourceFiles with @@ -2150,9 +2156,9 @@ type internal FsiInteractionProcessor let sourceFiles = List.map fst sourceFiles let istate = if isScript1 then - processor.EvalIncludedScripts (istate, sourceFiles, errorLogger) + processor.EvalIncludedScripts (ctok, istate, sourceFiles, errorLogger) else - istate |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalSourceFiles(istate, rangeStdin, sourceFiles, lexResourceManager, errorLogger), Completed None) |> fst + istate |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalSourceFiles(ctok, istate, rangeStdin, sourceFiles, lexResourceManager, errorLogger), Completed None) |> fst consume istate rest setCurrState (consume currState fsiOptions.SourceFiles) @@ -2162,10 +2168,10 @@ type internal FsiInteractionProcessor /// Send a dummy interaction through F# Interactive, to ensure all the most common code generation paths are /// JIT'ed and ready for use. - member __.LoadDummyInteraction(errorLogger) = - setCurrState (currState |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalParsedDefinitions (errorLogger, istate, true, false, []), Completed None) |> fst) + member __.LoadDummyInteraction(ctok, errorLogger) = + setCurrState (currState |> InteractiveCatch errorLogger (fun istate -> fsiDynamicCompiler.EvalParsedDefinitions (ctok, errorLogger, istate, true, false, []), Completed None) |> fst) - member __.EvalInteraction(sourceText, scriptFileName, errorLogger) = + member __.EvalInteraction(ctok, sourceText, scriptFileName, errorLogger) = use _unwind1 = ErrorLogger.PushThreadBuildPhaseUntilUnwind(ErrorLogger.BuildPhase.Interactive) use _unwind2 = ErrorLogger.PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger) #if FX_LCIDFROMCODEPAGE @@ -2176,15 +2182,15 @@ type internal FsiInteractionProcessor currState |> InteractiveCatch errorLogger (fun istate -> let expr = ParseInteraction tokenizer - mainThreadProcessParsedInteractions errorLogger (expr, istate) ) + mainThreadProcessParsedInteractions ctok errorLogger (expr, istate) ) |> commitResult - member this.EvalScript (scriptPath, errorLogger) = + member this.EvalScript (ctok, scriptPath, errorLogger) = // Todo: this runs the script as expected but errors are displayed one line to far in debugger let sourceText = sprintf "#load @\"%s\" " scriptPath - this.EvalInteraction (sourceText, scriptPath, errorLogger) + this.EvalInteraction (ctok, sourceText, scriptPath, errorLogger) - member __.EvalExpression (sourceText, scriptFileName, errorLogger) = + member __.EvalExpression (ctok, sourceText, scriptFileName, errorLogger) = use _unwind1 = ErrorLogger.PushThreadBuildPhaseUntilUnwind(ErrorLogger.BuildPhase.Interactive) use _unwind2 = ErrorLogger.PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger) #if FX_LCIDFROMCODEPAGE @@ -2198,7 +2204,7 @@ type internal FsiInteractionProcessor let m = expr.Range // Make this into "(); expr" to suppress generalization and compilation-as-function let exprWithSeq = SynExpr.Sequential(SequencePointInfoForSeq.SuppressSequencePointOnStmtOfSequential,true,SynExpr.Const(SynConst.Unit,m.StartRange), expr, m) - mainThreadProcessParsedExpression errorLogger (exprWithSeq, istate)) + mainThreadProcessParsedExpression ctok errorLogger (exprWithSeq, istate)) |> commitResult /// Start the background thread used to read the input reader and/or console @@ -2229,11 +2235,13 @@ type internal FsiInteractionProcessor if !progress then fprintfn fsiConsoleOutput.Out "READER: stdin thread got first line..."; + let runCodeOnMainThread = runCodeOnEventLoop errorLogger + // Keep going until EndOfFile on the inReader or console let rec loop currTokenizer = let istateNew,contNew = - processor.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnEventLoop errorLogger, currState, currTokenizer, errorLogger) + processor.ParseAndExecOneSetOfInteractionsFromLexbuf (runCodeOnMainThread, currState, currTokenizer, errorLogger) setCurrState istateNew @@ -2444,10 +2452,21 @@ let internal DriveFsiEventLoop (fsi: FsiEvaluationSessionHostConfig, fsiConsoleO /// The primary type, representing a full F# Interactive session, reading from the given /// text input, writing to the given text output and error writers. type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], inReader:TextReader, outWriter:TextWriter, errorWriter: TextWriter) = + #if !FX_NO_HEAPTERMINATION do if not runningOnMono then Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *) #endif + + // Explanation: When FsiEvaluationSession.Create is called we do a bunch of processing. For fsi.exe + // and fsiAnyCpu.exe there are no other active threads at this point, so we can assume this is the + // unique compilation thread. For other users of FsiEvaluationSession it is reasonable to assume that + // the object is not accessed concurrently during startup preparation. + // + // We later switch to doing interaction-by-interaction processing on the "event loop" thread. + let ctokStartup = AssumeCompilationThreadWithoutEvidence () + #if FX_LCIDFROMCODEPAGE + // See Bug 735819 let lcidFromCodePage = if (Console.OutputEncoding.CodePage <> 65001) && @@ -2458,6 +2477,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st else None #endif + let timeReporter = FsiTimeReporter(outWriter) #if !FX_RESHAPED_CONSOLE @@ -2565,7 +2585,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st let tcGlobals,tcImports = try - TcImports.BuildTcImports(tcConfigP) + TcImports.BuildTcImports(ctokStartup, tcConfigP) with e -> stopProcessingRecovery e range0; exit 1 @@ -2579,9 +2599,12 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st /// The lock stops the type checker running at the same time as the server intellisense implementation. let tcLockObject = box 7 // any new object will do - let resolveType (aref: ILAssemblyRef) = + let resolveAssemblyRef (aref: ILAssemblyRef) = + // Explanation: This callback is invoked during compilation to resolve assembly references + // We don't yet propagate the ctok through these calls (though it looks plausible to do so). + let ctok = AssumeCompilationThreadWithoutEvidence () #if EXTENSIONTYPING - match tcImports.TryFindProviderGeneratedAssemblyByName aref.Name with + match tcImports.TryFindProviderGeneratedAssemblyByName (ctok, aref.Name) with | Some assembly -> Some (Choice2Of2 assembly) | None -> #endif @@ -2589,7 +2612,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st | Some resolvedPath -> Some (Choice1Of2 resolvedPath) | None -> None - let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, ilGlobals, fsiOptions, fsiConsoleOutput, niceNameGen, resolveType) + let fsiDynamicCompiler = FsiDynamicCompiler(fsi, timeReporter, tcConfigB, tcLockObject, outWriter, tcImports, tcGlobals, ilGlobals, fsiOptions, fsiConsoleOutput, niceNameGen, resolveAssemblyRef) let fsiInterruptController = FsiInterruptController(fsiOptions, fsiConsoleOutput) @@ -2703,16 +2726,32 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st #endif member x.EvalExpression(sourceText) = - fsiInteractionProcessor.EvalExpression(sourceText, dummyScriptFileName, errorLogger) + + // Explanation: When the user of the FsiInteractiveSession object calls this method, the + // code is parsed, checked and evaluated on the calling thread. This means EvalExpression + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + fsiInteractionProcessor.EvalExpression(ctok, sourceText, dummyScriptFileName, errorLogger) |> commitResult member x.EvalInteraction(sourceText) : unit = - fsiInteractionProcessor.EvalInteraction(sourceText, dummyScriptFileName, errorLogger) + // Explanation: When the user of the FsiInteractiveSession object calls this method, the + // code is parsed, checked and evaluated on the calling thread. This means EvalExpression + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + fsiInteractionProcessor.EvalInteraction(ctok, sourceText, dummyScriptFileName, errorLogger) |> commitResult |> ignore member x.EvalScript(scriptPath) : unit = - fsiInteractionProcessor.EvalScript(scriptPath, errorLogger) + // Explanation: When the user of the FsiInteractiveSession object calls this method, the + // code is parsed, checked and evaluated on the calling thread. This means EvalExpression + // is not safe to call concurrently. + let ctok = AssumeCompilationThreadWithoutEvidence() + + fsiInteractionProcessor.EvalScript(ctok, scriptPath, errorLogger) |> commitResult |> ignore @@ -2731,6 +2770,14 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st [] member x.Run() = + // Explanation: When Run is called we do a bunch of processing. For fsi.exe + // and fsiAnyCpu.exe there are no other active threads at this point, so we can assume this is the + // unique compilation thread. For other users of FsiEvaluationSession it is reasonable to assume that + // the object is not accessed concurrently during startup preparation. + // + // We later switch to doing interaction-by-interaction processing on the "event loop" thread + let ctokRun = AssumeCompilationThreadWithoutEvidence () + // Update the console completion function now we've got an initial type checking state. // This means completion doesn't work until the initial type checking state has finished loading - fair enough! match fsiConsoleInput.TryGetConsole() with @@ -2743,11 +2790,11 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st SpawnInteractiveServer (fsiOptions, fsiConsoleOutput, fsiInterruptController) #endif - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Interactive) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Interactive if fsiOptions.Interact then // page in the type check env - fsiInteractionProcessor.LoadDummyInteraction(errorLogger) + fsiInteractionProcessor.LoadDummyInteraction(ctokStartup, errorLogger) if !progress then fprintfn fsiConsoleOutput.Out "MAIN: InstallKillThread!"; // Compute how long to pause before a ThreadAbort is actually executed. @@ -2785,7 +2832,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st // This is the event loop for winforms fsi.SetEventLoop (WinFormsEventLoop(fsiConsoleOutput, fsiOptions.FsiLCID)) #endif - fsiInteractionProcessor.LoadInitialFiles(errorLogger) + fsiInteractionProcessor.LoadInitialFiles(ctokRun, errorLogger) fsiInteractionProcessor.StartStdinReadAndProcessThread(errorLogger) @@ -2793,7 +2840,7 @@ type internal FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:st else // not interact if !progress then fprintfn fsiConsoleOutput.Out "Run: not interact, loading intitial files..." - fsiInteractionProcessor.LoadInitialFiles(errorLogger) + fsiInteractionProcessor.LoadInitialFiles(ctokRun, errorLogger) if !progress then fprintfn fsiConsoleOutput.Out "Run: done..." exit (min errorLogger.ErrorCount 1) diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index c0bca3ec1e..feed9f416c 100644 --- a/src/fsharp/import.fs +++ b/src/fsharp/import.fs @@ -26,13 +26,13 @@ open Microsoft.FSharp.Compiler.ExtensionTyping type AssemblyLoader = /// Resolve an Abstract IL assembly reference to a Ccu - abstract LoadAssembly : range * ILAssemblyRef -> CcuResolutionResult + abstract FindCcuFromAssemblyRef : CompilationThreadToken * range * ILAssemblyRef -> CcuResolutionResult #if EXTENSIONTYPING /// Get a flag indicating if an assembly is a provided assembly, plus the /// table of information recording remappings from type names in the provided assembly to type /// names in the statically linked, embedded assembly. - abstract GetProvidedAssemblyInfo : range * Tainted -> bool * ProvidedAssemblyStaticLinkingMap option + abstract GetProvidedAssemblyInfo : CompilationThreadToken * range * Tainted -> bool * ProvidedAssemblyStaticLinkingMap option /// Record a root for a [] type to help guide static linking & type relocation abstract RecordGeneratedTypeRoot : ProviderGeneratedType -> unit @@ -64,18 +64,28 @@ let CanImportILScopeRef (env:ImportMap) m scoref = | ILScopeRef.Local -> true | ILScopeRef.Module _ -> true | ILScopeRef.Assembly assref -> - match env.assemblyLoader.LoadAssembly (m,assref) with + + // Explanation: This represents an unchecked invariant in the hosted compiler: that any operations + // which import types (and resolve assemblies from the tcImports tables) happen on the compilation thread. + let ctok = AssumeCompilationThreadWithoutEvidence() + + match env.assemblyLoader.FindCcuFromAssemblyRef (ctok, m, assref) with | UnresolvedCcu _ -> false | ResolvedCcu _ -> true /// Import a reference to a type definition, given the AbstractIL data for the type reference let ImportTypeRefData (env:ImportMap) m (scoref,path,typeName) = + + // Explanation: This represents an unchecked invariant in the hosted compiler: that any operations + // which import types (and resolve assemblies from the tcImports tables) happen on the compilation thread. + let ctok = AssumeCompilationThreadWithoutEvidence() + let ccu = match scoref with | ILScopeRef.Local -> error(InternalError("ImportILTypeRef: unexpected local scope",m)) | ILScopeRef.Module _ -> error(InternalError("ImportILTypeRef: reference found to a type in an auxiliary module",m)) - | ILScopeRef.Assembly assref -> env.assemblyLoader.LoadAssembly (m,assref) // NOTE: only assemblyLoader callsite + | ILScopeRef.Assembly assref -> env.assemblyLoader.FindCcuFromAssemblyRef (ctok, m, assref) // NOTE: only assemblyLoader callsite // Do a dereference of a fake tcref for the type just to check it exists in the target assembly and to find // the corresponding Tycon. @@ -235,6 +245,15 @@ let rec ImportProvidedTypeAsILType (env:ImportMap) (m:range) (st:Tainted) = + // Explanation: The two calls below represent am unchecked invariant of the hosted compiler: + // that type providers are only activated on the CompilationThread. This invariant is not currently checked + // via CompilationThreadToken passing. We leave the two calls below as a reminder of this. + // + // This function is one major source of type provider activations, but not the only one: almost + // any call in the 'ExtensionTyping' module is a potential type provider activation. + let ctok = AssumeCompilationThreadWithoutEvidence () + RequireCompilationThread ctok + let g = env.g if st.PUntaint((fun st -> st.IsArray),m) then let elemTy = (ImportProvidedType env m (* tinst *) (st.PApply((fun st -> st.GetElementType()),m))) diff --git a/src/fsharp/import.fsi b/src/fsharp/import.fsi index a7826fa411..a7e81a9709 100644 --- a/src/fsharp/import.fsi +++ b/src/fsharp/import.fsi @@ -7,6 +7,7 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping #endif @@ -18,13 +19,13 @@ open Microsoft.FSharp.Compiler.ExtensionTyping type AssemblyLoader = /// Resolve an Abstract IL assembly reference to a Ccu - abstract LoadAssembly : range * ILAssemblyRef -> CcuResolutionResult + abstract FindCcuFromAssemblyRef : CompilationThreadToken * range * ILAssemblyRef -> CcuResolutionResult #if EXTENSIONTYPING /// Get a flag indicating if an assembly is a provided assembly, plus the /// table of information recording remappings from type names in the provided assembly to type /// names in the statically linked, embedded assembly. - abstract GetProvidedAssemblyInfo : range * Tainted -> bool * ProvidedAssemblyStaticLinkingMap option + abstract GetProvidedAssemblyInfo : CompilationThreadToken * range * Tainted -> bool * ProvidedAssemblyStaticLinkingMap option /// Record a root for a [] type to help guide static linking & type relocation abstract RecordGeneratedTypeRoot : ProviderGeneratedType -> unit diff --git a/src/fsharp/lexhelp.fs b/src/fsharp/lexhelp.fs index b68f5893ce..3cd9b74ce1 100644 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -72,7 +72,7 @@ let mkLexargs (_filename,defines,lightSyntaxStatus,resourceManager,ifdefStack,er /// Register the lexbuf and call the given function let reusingLexbufForParsing lexbuf f = - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse LexbufLocalXmlDocStore.ClearXmlDoc lexbuf try f () @@ -354,4 +354,4 @@ module Keywords = /// Quote identifier with double backticks if needed, remove unnecessary double backticks quotation. let NormalizeIdentifierBackticks (s : string) : string = let s = if s.StartsWith "``" && s.EndsWith "``" then s.[2..s.Length - 3] else s - QuoteIdentifierIfNeeded s \ No newline at end of file + QuoteIdentifierIfNeeded s diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi index 36b01048c7..c5f0d03674 100644 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -8,6 +8,7 @@ open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 0485971c37..74e6e6115a 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -34,20 +34,20 @@ open Microsoft.FSharp.Core.CompilerServices /// Unique name generator for stamps attached to lambdas and object expressions type Unique = int64 -//++GLOBAL MUTABLE STATE +//++GLOBAL MUTABLE STATE (concurrency-safe) let newUnique = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment(i) type Stamp = int64 /// Unique name generator for stamps attached to to val_specs, tycon_specs etc. -//++GLOBAL MUTABLE STATE +//++GLOBAL MUTABLE STATE (concurrency-safe) let newStamp = let i = ref 0L in fun () -> System.Threading.Interlocked.Increment(i) /// A global generator of compiler generated names -// ++GLOBAL MUTABLE STATE +// ++GLOBAL MUTABLE STATE (concurrency safe by locking inside NiceNameGenerator) let globalNng = NiceNameGenerator() /// A global generator of stable compiler generated names -// ++GLOBAL MUTABLE STATE +// ++GLOBAL MUTABLE STATE (concurrency safe by locking inside StableNiceNameGenerator) let globalStableNameGenerator = StableNiceNameGenerator () type StampMap<'T> = Map diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs index 04d6bb363d..2a36d0dbba 100755 --- a/src/fsharp/vs/IncrementalBuild.fs +++ b/src/fsharp/vs/IncrementalBuild.fs @@ -46,13 +46,13 @@ module internal IncrementalBuild = /// ScalarDemultiplex (uniqueRuleId, outputName, input, taskFunction) /// /// A build rule representing the merge of a set of inputs to a single output - | ScalarDemultiplex of Id * string * VectorBuildRule * (obj[] -> obj) + | ScalarDemultiplex of Id * string * VectorBuildRule * (CompilationThreadToken -> obj[] -> obj) /// ScalarMap (uniqueRuleId, outputName, input, taskFunction) /// /// A build rule representing the transformation of a single input to a single output /// THIS CASE IS CURRENTLY UNUSED - | ScalarMap of Id * string * ScalarBuildRule * (obj->obj) + | ScalarMap of Id * string * ScalarBuildRule * (CompilationThreadToken -> obj -> obj) /// Get the Id for the given ScalarBuildRule. member x.Id = @@ -77,39 +77,39 @@ module internal IncrementalBuild = /// VectorInput (uniqueRuleId, outputName, initialAccumulator, inputs, taskFunction) /// /// A build rule representing the scan-left combining a single scalar accumulator input with a vector of inputs - | VectorScanLeft of Id * string * ScalarBuildRule * VectorBuildRule * (obj->obj->Eventually) + | VectorScanLeft of Id * string * ScalarBuildRule * VectorBuildRule * (CompilationThreadToken -> obj -> obj->Eventually) /// VectorMap (uniqueRuleId, outputName, inputs, taskFunction) /// /// A build rule representing the parallel map of the inputs to outputs - | VectorMap of Id * string * VectorBuildRule * (obj->obj) + | VectorMap of Id * string * VectorBuildRule * (CompilationThreadToken -> obj -> obj) /// VectorStamp (uniqueRuleId, outputName, inputs, stampFunction) /// /// A build rule representing pairing the inputs with a timestamp specified by the given function. - | VectorStamp of Id * string * VectorBuildRule * (obj->DateTime) + | VectorStamp of Id * string * VectorBuildRule * (CompilationThreadToken -> obj -> DateTime) /// VectorMultiplex (uniqueRuleId, outputName, input, taskFunction) /// /// A build rule representing taking a single input and transforming it to a vector of outputs - | VectorMultiplex of Id * string * ScalarBuildRule * (obj->obj[]) + | VectorMultiplex of Id * string * ScalarBuildRule * (CompilationThreadToken -> obj -> obj[]) /// Get the Id for the given VectorBuildRule. member x.Id = match x with - | VectorInput(id,_) ->id - | VectorScanLeft(id,_,_,_,_) ->id - | VectorMap(id,_,_,_) ->id - | VectorStamp (id,_,_,_) ->id - | VectorMultiplex(id,_,_,_) ->id + | VectorInput(id,_) -> id + | VectorScanLeft(id,_,_,_,_) -> id + | VectorMap(id,_,_,_) -> id + | VectorStamp (id,_,_,_) -> id + | VectorMultiplex(id,_,_,_) -> id /// Get the Name for the given VectorBuildRule. member x.Name = match x with - | VectorInput(_,n) ->n - | VectorScanLeft(_,n,_,_,_) ->n - | VectorMap(_,n,_,_) ->n - | VectorStamp (_,n,_,_) ->n - | VectorMultiplex(_,n,_,_) ->n + | VectorInput(_,n) -> n + | VectorScanLeft(_,n,_,_,_) -> n + | VectorMap(_,n,_,_) -> n + | VectorStamp (_,n,_,_) -> n + | VectorMultiplex(_,n,_,_) -> n [] type BuildRuleExpr = @@ -159,17 +159,17 @@ module internal IncrementalBuild = let FoldOverBuildRules(rules:BuildRules, op, acc)= let rec visitVector (ve:VectorBuildRule) acc = match ve with - | VectorInput _ ->op (VectorBuildRule ve) acc - | VectorScanLeft(_,_,a,i,_) ->op (VectorBuildRule ve) (visitVector i (visitScalar a acc)) + | VectorInput _ -> op (VectorBuildRule ve) acc + | VectorScanLeft(_,_,a,i,_) -> op (VectorBuildRule ve) (visitVector i (visitScalar a acc)) | VectorMap(_,_,i,_) - | VectorStamp (_,_,i,_) ->op (VectorBuildRule ve) (visitVector i acc) - | VectorMultiplex(_,_,i,_) ->op (VectorBuildRule ve) (visitScalar i acc) + | VectorStamp (_,_,i,_) -> op (VectorBuildRule ve) (visitVector i acc) + | VectorMultiplex(_,_,i,_) -> op (VectorBuildRule ve) (visitScalar i acc) and visitScalar (se:ScalarBuildRule) acc = match se with - | ScalarInput _ ->op (ScalarBuildRule se) acc - | ScalarDemultiplex(_,_,i,_) ->op (ScalarBuildRule se) (visitVector i acc) - | ScalarMap(_,_,i,_) ->op (ScalarBuildRule se) (visitScalar i acc) + | ScalarInput _ -> op (ScalarBuildRule se) acc + | ScalarDemultiplex(_,_,i,_) -> op (ScalarBuildRule se) (visitVector i acc) + | ScalarMap(_,_,i,_) -> op (ScalarBuildRule se) (visitScalar i acc) let visitRule (expr:BuildRuleExpr) acc = match expr with @@ -227,7 +227,7 @@ module internal IncrementalBuild = /// A slot for holding a single result. type Result = | NotAvailable - | InProgress of (unit -> Eventually) * DateTime + | InProgress of (CompilationThreadToken -> Eventually) * DateTime | Available of obj * DateTime * InputSignature /// Get the available result. Throw an exception if not available. @@ -240,7 +240,7 @@ module internal IncrementalBuild = member x.InputSignature = match x with Available(_,_,signature) -> signature | _ -> UnevaluatedInput member x.ResultIsInProgress = match x with | InProgress _ -> true | _ -> false - member x.GetInProgressContinuation() = match x with | InProgress (f,_) -> f() | _ -> failwith "not in progress" + member x.GetInProgressContinuation ctok = match x with | InProgress (f,_) -> f ctok | _ -> failwith "not in progress" member x.TryGetAvailable() = match x with | InProgress _ | NotAvailable -> None | Available(obj,dt,i) -> Some (obj,dt,i) /// An immutable sparse vector of results. @@ -295,16 +295,16 @@ module internal IncrementalBuild = /// A pending action over the bound build tree [] type Action = - | IndexedAction of Id * (*taskname*)string * int * (*slotcount*) int * DateTime * (unit->Eventually) - | ScalarAction of Id * (*taskname*)string * DateTime * InputSignature * (unit->obj) - | VectorAction of Id * (*taskname*)string * DateTime * InputSignature * (unit->obj[]) + | IndexedAction of Id * (*taskname*)string * int * (*slotcount*) int * DateTime * (CompilationThreadToken -> Eventually) + | ScalarAction of Id * (*taskname*)string * DateTime * InputSignature * (CompilationThreadToken -> obj) + | VectorAction of Id * (*taskname*)string * DateTime * InputSignature * (CompilationThreadToken -> obj[]) | ResizeResultAction of Id * (*slotcount*) int /// Execute one action and return a corresponding result. - member action.Execute() = + member action.Execute(ctok) = match action with - | IndexedAction(id,_taskname,slot,slotcount,timestamp,func) -> IndexedResult(id,slot,slotcount,func(),timestamp) - | ScalarAction(id,_taskname,timestamp,inputsig,func) -> ScalarValuedResult(id,func(),timestamp,inputsig) - | VectorAction(id,_taskname,timestamp,inputsig,func) -> VectorValuedResult(id,func(),timestamp,inputsig) + | IndexedAction(id,_taskname,slot,slotcount,timestamp,func) -> IndexedResult(id,slot,slotcount,func ctok,timestamp) + | ScalarAction(id,_taskname,timestamp,inputsig,func) -> ScalarValuedResult(id,func ctok,timestamp,inputsig) + | VectorAction(id,_taskname,timestamp,inputsig,func) -> VectorValuedResult(id,func ctok,timestamp,inputsig) | ResizeResultAction(id,slotcount) -> ResizeResult(id,slotcount) /// A set of build rules and the corresponding, possibly partial, results from building. @@ -506,7 +506,7 @@ module internal IncrementalBuild = /// Visit each executable action necessary to evaluate the given output (with an optional slot in a /// vector output). Call actionFunc with the given accumulator. - let ForeachAction (Target(output, optSlot)) bt (actionFunc:Action->'acc->'acc) (acc:'acc) = + let ForeachAction ctok (Target(output, optSlot)) bt (actionFunc:Action -> 'T -> 'T) (acc:'T) = let seen = Dictionary() let isSeen id = if seen.ContainsKey id then true @@ -527,7 +527,7 @@ module internal IncrementalBuild = | Some found -> match found with | VectorResult rv -> - if rv.Size<> expectedWidth then + if rv.Size <> expectedWidth then actionFunc (ResizeResultAction(ve.Id ,expectedWidth)) acc else acc | _ -> acc @@ -540,7 +540,7 @@ module internal IncrementalBuild = else let acc = resizeVectorExpr(ve,acc) match ve with - | VectorInput _ ->acc + | VectorInput _ -> acc | VectorScanLeft(id,taskname,accumulatorExpr,inputExpr,func) -> let acc = match GetVectorWidthByExpr(bt,ve) with @@ -558,15 +558,15 @@ module internal IncrementalBuild = let inputtimestamp = max inputtimestamp accumulatortimesamp let prevoutput = GetVectorExprResult (bt,ve,slot) let outputtimestamp = prevoutput.Timestamp - let scanOp = + let scanOpOpt = if inputtimestamp <> outputtimestamp then - Some (fun () -> func accumulator input) + Some (fun ctok -> func ctok accumulator input) elif prevoutput.ResultIsInProgress then Some prevoutput.GetInProgressContinuation else // up-to-date and complete, no work required None - match scanOp with + match scanOpOpt with | Some scanOp -> Some (actionFunc (IndexedAction(id,taskname,slot,cardinality,inputtimestamp,scanOp)) acc) | None -> None | _ -> None @@ -593,8 +593,8 @@ module internal IncrementalBuild = let inputtimestamp = GetVectorExprResult(bt,inputExpr,slot).Timestamp let outputtimestamp = GetVectorExprResult(bt,ve,slot).Timestamp if inputtimestamp <> outputtimestamp then - let OneToOneOp() = - Eventually.Done (func (GetVectorExprResult(bt,inputExpr,slot).GetAvailable())) + let OneToOneOp ctok = + Eventually.Done (func ctok (GetVectorExprResult(bt,inputExpr,slot).GetAvailable())) actionFunc (IndexedAction(id,taskname,slot,cardinality,inputtimestamp,OneToOneOp)) acc else acc match optSlot with @@ -625,7 +625,7 @@ module internal IncrementalBuild = match inputresult with | Available(ires,_,_) -> let oldtimestamp = GetVectorExprResult(bt,ve,slot).Timestamp - let newtimestamp = func ires + let newtimestamp = func ctok ires if newtimestamp <> oldtimestamp then actionFunc (IndexedAction(id,taskname,slot,cardinality,newtimestamp, fun _ -> Eventually.Done ires)) acc else acc @@ -644,7 +644,7 @@ module internal IncrementalBuild = | Available(inp,inputtimestamp,inputsig) -> let outputtimestamp = MaxTimestamp(bt,id) if inputtimestamp <> outputtimestamp then - let MultiplexOp() = func inp + let MultiplexOp ctok = func ctok inp actionFunc (VectorAction(id,taskname,inputtimestamp,inputsig,MultiplexOp)) acc else acc | _ -> acc @@ -662,9 +662,9 @@ module internal IncrementalBuild = let currentsig = inputresult.Signature() if shouldEvaluate(bt,currentsig,id) then let inputtimestamp = MaxTimestamp(bt, inputExpr.Id) - let DemultiplexOp() = + let DemultiplexOp ctok = let input = AvailableAllResultsOfExpr bt inputExpr |> List.toArray - func input + func ctok input actionFunc (ScalarAction(id,taskname,inputtimestamp,currentsig,DemultiplexOp)) acc else acc | None -> acc @@ -677,7 +677,7 @@ module internal IncrementalBuild = | Available(inp,inputtimestamp,inputsig) -> let outputtimestamp = MaxTimestamp(bt, id) if inputtimestamp <> outputtimestamp then - let MapOp() = func inp + let MapOp ctok = func ctok inp actionFunc (ScalarAction(id,taskname,inputtimestamp,inputsig,MapOp)) acc else acc | _ -> acc @@ -689,9 +689,15 @@ module internal IncrementalBuild = match expr with | ScalarBuildRule se -> visitScalar se acc | VectorBuildRule ve -> visitVector optSlot ve acc + + let CollectActions target (bt: PartialBuild) = + // Explanation: This is a false reuse of 'ForeachAction' where the ctok is unused, we are + // just iterating to determine if there is work to do. This means this is safe to call from any thread. + let ctok = AssumeCompilationThreadWithoutEvidence () + ForeachAction ctok target bt (fun a l -> a :: l) [] /// Compute the max timestamp on all available inputs - let ComputeMaxTimeStamp output (bt: PartialBuild) acc = + let ComputeMaxTimeStamp ctok output (bt: PartialBuild) acc = let expr = bt.Rules.RuleList |> List.find (fun (s,_) -> s = output) |> snd match expr with | VectorBuildRule (VectorStamp (_id, _taskname, inputExpr, func) as ve) -> @@ -699,7 +705,7 @@ module internal IncrementalBuild = | Some cardinality -> let CheckStamp acc slot = match GetVectorExprResult (bt,inputExpr,slot) with - | Available(ires,_,_) -> max acc (func ires) + | Available(ires,_,_) -> max acc (func ctok ires) | _ -> acc [0..cardinality-1] |> List.fold CheckStamp acc | None -> acc @@ -756,19 +762,19 @@ module internal IncrementalBuild = /// Apply the result, and call the 'save' function to update the build. /// - /// Will throw OperationCanceledException if the cancellation token has been set. - let ExecuteApply save (ct: CancellationToken) (action:Action) bt = + /// Will throw OperationCanceledException if the cancellation ctok has been set. + let ExecuteApply (ctok: CompilationThreadToken) save (ct: CancellationToken) (action:Action) bt = ct.ThrowIfCancellationRequested() if (injectCancellationFault) then raise (OperationCanceledException("injected fault")) - let actionResult = action.Execute() + let actionResult = action.Execute(ctok) let newBt = ApplyResult(actionResult,bt) - save newBt + save ctok newBt newBt /// Evaluate the result of a single output /// - /// Will throw OperationCanceledException if the cancellation token has been set. - let EvalLeafsFirst save (ct: CancellationToken) target bt = + /// Will throw OperationCanceledException if the cancellation ctok has been set. + let EvalLeafsFirst ctok save (ct: CancellationToken) target bt = let rec eval(bt,gen) = #if DEBUG @@ -776,43 +782,43 @@ module internal IncrementalBuild = // Possibly could detect this case directly. if gen>5000 then failwith "Infinite loop in incremental builder?" #endif - let newBt = ForeachAction target bt (ExecuteApply save ct) bt + let newBt = ForeachAction ctok target bt (ExecuteApply ctok save ct) bt if newBt=bt then bt else eval(newBt,gen+1) eval(bt,0) /// Evaluate one step of the build. Call the 'save' function to save the intermediate result. /// - /// Will throw OperationCanceledException if the cancellation token has been set. - let Step save ct target (bt:PartialBuild) = + /// Will throw OperationCanceledException if the cancellation ctok has been set. + let Step ctok save ct target (bt:PartialBuild) = - // Hey look, we're building up the whole list, executing one thing and then throwing - // the list away. What about saving the list inside the Build instance? - let worklist = ForeachAction target bt (fun a l -> a :: l) [] + // REVIEW: we're building up the whole list of actions on the fringe of the work tree, + // executing one thing and then throwing the list away. What about saving the list inside the Build instance? + let worklist = CollectActions target bt match worklist with - | action::_ -> Some (ExecuteApply save ct action bt) + | action::_ -> Some (ExecuteApply ctok save ct action bt) | _ -> None /// Evaluate an output of the build. /// - /// Will throw OperationCanceledException if the cancellation token has been set. Intermediate + /// Will throw OperationCanceledException if the cancellation ctok has been set. Intermediate /// progrewss along the way may be saved through the use of the 'save' function. - let Eval save ct node bt = EvalLeafsFirst save ct (Target(node,None)) bt + let Eval ctok save ct node bt = EvalLeafsFirst ctok save ct (Target(node,None)) bt /// Evaluate an output of the build. /// - /// Will throw OperationCanceledException if the cancellation token has been set. Intermediate + /// Will throw OperationCanceledException if the cancellation ctok has been set. Intermediate /// progrewss along the way may be saved through the use of the 'save' function. - let EvalUpTo save ct (node, n) bt = EvalLeafsFirst save ct (Target(node, Some n)) bt + let EvalUpTo ctok save ct (node, n) bt = EvalLeafsFirst ctok save ct (Target(node, Some n)) bt /// Check if an output is up-to-date and ready let IsReady target bt = - let worklist = ForeachAction target bt (fun a l -> a :: l) [] + let worklist = CollectActions target bt worklist.IsEmpty /// Check if an output is up-to-date and ready - let MaxTimeStampInDependencies target bt = - ComputeMaxTimeStamp target bt DateTime.MinValue + let MaxTimeStampInDependencies ctok target bt = + ComputeMaxTimeStamp ctok target bt DateTime.MinValue /// Get a scalar vector. Result must be available let GetScalarResult<'T>(node:Scalar<'T>,bt): ('T*DateTime) option = @@ -834,7 +840,7 @@ module internal IncrementalBuild = let GetVectorResult<'T>(node:Vector<'T>,bt): 'T[] = match GetTopLevelExprByName(bt,node.Name) with | ScalarBuildRule _ -> failwith "Expected vector." - | VectorBuildRule ve -> AvailableAllResultsOfExpr bt ve |> List.map (unbox) |> Array.ofList + | VectorBuildRule ve -> AvailableAllResultsOfExpr bt ve |> List.map unbox |> Array.ofList /// Get an element of vector result or None if there were no results. let GetVectorResultBySlot<'T>(node:Vector<'T>,slot,bt): ('T*DateTime) option = @@ -889,9 +895,9 @@ module internal IncrementalBuild = module Vector = /// Maps one vector to another using the given function. - let Map (taskname:string) (task:'I ->'O) (input:Vector<'I>): Vector<'O> = + let Map (taskname:string) (task: CompilationThreadToken -> 'I -> 'O) (input:Vector<'I>): Vector<'O> = let input = input.Expr - let expr = VectorMap(NextId(),taskname,input,unbox >> task >> box) + let expr = VectorMap(NextId(),taskname,input,(fun ctok x -> box (task ctok (unbox x)))) { new Vector<'O> interface IVector with override __.Name = taskname @@ -900,8 +906,8 @@ module internal IncrementalBuild = /// Apply a function to each element of the vector, threading an accumulator argument /// through the computation. Returns intermediate results in a vector. - let ScanLeft (taskname:string) (task:'A -> 'I -> Eventually<'A>) (acc:Scalar<'A>) (input:Vector<'I>): Vector<'A> = - let BoxingScanLeft a i = Eventually.box(task (unbox a) (unbox i)) + let ScanLeft (taskname:string) (task: CompilationThreadToken -> 'A -> 'I -> Eventually<'A>) (acc:Scalar<'A>) (input:Vector<'I>): Vector<'A> = + let BoxingScanLeft ctok a i = Eventually.box(task ctok (unbox a) (unbox i)) let acc = acc.Expr let input = input.Expr let expr = VectorScanLeft(NextId(),taskname,acc,input,BoxingScanLeft) @@ -911,9 +917,9 @@ module internal IncrementalBuild = override pe.Expr = expr } /// Apply a function to a vector to get a scalar value. - let Demultiplex (taskname:string) (task:'I[] -> 'O) (input:Vector<'I>): Scalar<'O> = - let BoxingDemultiplex i = - box(task (Array.map unbox i) ) + let Demultiplex (taskname:string) (task: CompilationThreadToken -> 'I[] -> 'O) (input:Vector<'I>): Scalar<'O> = + let BoxingDemultiplex ctok i = + box(task ctok (Array.map unbox i) ) let input = input.Expr let expr = ScalarDemultiplex(NextId(),taskname,input,BoxingDemultiplex) { new Scalar<'O> @@ -923,16 +929,16 @@ module internal IncrementalBuild = /// Creates a new vector with the same items but with /// timestamp specified by the passed-in function. - let Stamp (taskname:string) (task:'I -> DateTime) (input:Vector<'I>): Vector<'I> = + let Stamp (taskname:string) (task: CompilationThreadToken -> 'I -> DateTime) (input:Vector<'I>): Vector<'I> = let input = input.Expr - let expr = VectorStamp (NextId(),taskname,input,unbox >> task) + let expr = VectorStamp (NextId(),taskname,input,(fun ctok x -> task ctok (unbox x))) { new Vector<'I> interface IVector with override __.Name = taskname override pe.Expr = expr } let AsScalar (taskname:string) (input:Vector<'I>): Scalar<'I array> = - Demultiplex taskname (fun v->v) input + Demultiplex taskname (fun _ctok x -> x) input /// Declare build outputs and bind them to real values. type BuildDescriptionScope() = @@ -996,7 +1002,7 @@ type FSharpErrorInfo(fileName, s:pos, e:pos, severity: FSharpErrorSeverity, mess type ErrorScope() = let mutable errors = [] static let mutable mostRecentError = None - let unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) + let unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck let unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> { new ErrorLogger("ErrorScope") with @@ -1108,14 +1114,17 @@ type TypeCheckAccumulator = type FrameworkImportsCacheKey = (*resolvedpath*)string list * string * (*TargetFrameworkDirectories*)string list* (*fsharpBinaries*)string type FrameworkImportsCache(keepStrongly) = - let frameworkTcImportsCache = AgedLookup(keepStrongly, areSame=(fun (x,y) -> x = y)) - member __.Downsize() = frameworkTcImportsCache.Resize(keepStrongly=0) - member __.Clear() = frameworkTcImportsCache.Clear() + + // Mutable collection protected via CompilationThreadToken + let frameworkTcImportsCache = AgedLookup(keepStrongly, areSame=(fun (x,y) -> x = y)) + + member __.Downsize(ctok) = frameworkTcImportsCache.Resize(ctok, keepStrongly=0) + member __.Clear(ctok) = frameworkTcImportsCache.Clear(ctok) /// This function strips the "System" assemblies from the tcConfig and returns a age-cached TcImports for them. - member __.Get(tcConfig:TcConfig) = + member __.Get(ctok, tcConfig:TcConfig) = // Split into installed and not installed. - let frameworkDLLs,nonFrameworkResolutions,unresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(tcConfig) + let frameworkDLLs,nonFrameworkResolutions,unresolved = TcAssemblyResolutions.SplitNonFoundationalResolutions(ctok, tcConfig) let frameworkDLLsKey = frameworkDLLs |> List.map (fun ar->ar.resolvedPath) // The cache key. Just the minimal data. @@ -1129,14 +1138,15 @@ type FrameworkImportsCache(keepStrongly) = // FSharp.Core.dll and mscorlib.dll) must be logically invariant of all the other compiler configuration parameters. let key = (frameworkDLLsKey, tcConfig.primaryAssembly.Name, - tcConfig.TargetFrameworkDirectories, + tcConfig.GetTargetFrameworkDirectories(), tcConfig.fsharpBinariesDir) - match frameworkTcImportsCache.TryGet key with + + match frameworkTcImportsCache.TryGet (ctok, key) with | Some res -> res | None -> let tcConfigP = TcConfigProvider.Constant(tcConfig) - let ((tcGlobals,tcImports) as res) = TcImports.BuildFrameworkTcImports (tcConfigP, frameworkDLLs, nonFrameworkResolutions) - frameworkTcImportsCache.Put(key,res) + let ((tcGlobals,tcImports) as res) = TcImports.BuildFrameworkTcImports (ctok, tcConfigP, frameworkDLLs, nonFrameworkResolutions) + frameworkTcImportsCache.Put(ctok, key, res) tcGlobals,tcImports tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolved @@ -1164,10 +1174,9 @@ type internal CompilationErrorLogger (debugName:string, tcConfig:TcConfig) = /// This represents the global state established as each task function runs as part of the build. /// /// Use to reset error and warning handlers. -type CompilationGlobalsScope(errorLogger:ErrorLogger,phase,projectDirectory) = - do ignore projectDirectory +type CompilationGlobalsScope(errorLogger:ErrorLogger, phase: BuildPhase) = let unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _ -> errorLogger) - let unwindBP = PushThreadBuildPhaseUntilUnwind (phase) + let unwindBP = PushThreadBuildPhaseUntilUnwind phase // Return the disposable object that cleans up interface IDisposable with member d.Dispose() = @@ -1254,18 +1263,10 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig,tcGlobals,tcState:Tc /// Manages an incremental build graph for the build of a single F# project -type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig: TcConfig, projectDirectory, outfile, +type IncrementalBuilder(ctokCtor: CompilationThreadToken, frameworkTcImportsCache: FrameworkImportsCache, tcConfig: TcConfig, projectDirectory, outfile, assemblyName, niceNameGen: Ast.NiceNameGenerator, lexResourceManager, - sourceFiles, projectReferences: IProjectReference list, loadClosureOpt: LoadClosure option, ensureReactive, - keepAssemblyContents, keepAllBackgroundResolutions) = - - /// Maximum time share for a piece of background work before it should (cooperatively) yield - /// to enable other requests to be serviced. Yielding means returning a continuation function - /// (via an Eventually<_> value of case NotYetDone) that can be called as the next piece of work. - let maxTimeShareMilliseconds = - match System.Environment.GetEnvironmentVariable("FCS_MaxTimeShare") with - | null | "" -> 50L - | s -> int64 s + sourceFiles, projectReferences: IProjectReference list, loadClosureOpt: LoadClosure option, + keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) = let tcConfigP = TcConfigProvider.Constant(tcConfig) let importsInvalidated = new Event() @@ -1277,7 +1278,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // Resolve assemblies and create the framework TcImports. This is done when constructing the // builder itself, rather than as an incremental task. This caches a level of "system" references. No type providers are // included in these references. - let (tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolvedReferences) = frameworkTcImportsCache.Get tcConfig + let (tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolvedReferences) = frameworkTcImportsCache.Get(ctokCtor, tcConfig) // Check for the existence of loaded sources and prepend them to the sources list if present. let sourceFiles = tcConfig.GetAvailableLoadedSources() @ (sourceFiles |>List.map (fun s -> rangeStartup,s)) @@ -1296,7 +1297,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // This is ok because not much can actually go wrong here. let errorLogger = CompilationErrorLogger("nonFrameworkAssemblyInputs", tcConfig) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger,BuildPhase.Parameter, projectDirectory) + use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) [ for r in nonFrameworkResolutions do let originalTimeStamp = @@ -1340,7 +1341,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a VectorStamp /// /// Get the timestamp of the given file name. - let StampFileNameTask (_m:range, filename:string, _isLastCompiland) = + let StampFileNameTask _ctok (_m:range, filename:string, _isLastCompiland) = assertNotDisposed() FileSystem.GetLastWriteTimeShim(filename) @@ -1349,11 +1350,13 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// Parse the given files and return the given inputs. This function is expected to be /// able to be called with a subset of sourceFiles and return the corresponding subset of /// parsed inputs. - let ParseTask (sourceRange:range,filename:string,isLastCompiland) = + let ParseTask ctok (sourceRange:range,filename:string,isLastCompiland) = assertNotDisposed() + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + let errorLogger = CompilationErrorLogger("ParseTask", tcConfig) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parse, projectDirectory) + use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parse) try IncrementalBuilderEventTesting.MRU.Add(IncrementalBuilderEventTesting.IBEParsed filename) @@ -1368,16 +1371,18 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a Vector.Stamp /// /// Timestamps of referenced assemblies are taken from the file's timestamp. - let TimestampReferencedAssemblyTask (ref, originalTimeStamp) = + let TimestampReferencedAssemblyTask ctok (assemblyReference, originalTimeStamp) = assertNotDisposed() + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + // Note: we are not calling errorLogger.GetErrors() anywhere. Not a problem because timestamping can't really fail let errorLogger = CompilationErrorLogger("TimestampReferencedAssemblyTask", tcConfig) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter, projectDirectory) // Parameter because -r reference + use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) // Parameter because -r reference let timestamp = try - match ref with + match assemblyReference with | Choice1Of2 (filename) -> if FileSystem.SafeExists(filename) then FileSystem.GetLastWriteTimeShim(filename) @@ -1395,11 +1400,11 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a Vector.Demultiplex /// // Link all the assemblies together and produce the input typecheck accumulator - let CombineImportedAssembliesTask _: TypeCheckAccumulator = + let CombineImportedAssembliesTask ctok _ : TypeCheckAccumulator = assertNotDisposed() let errorLogger = CompilationErrorLogger("CombineImportedAssembliesTask", tcConfig) // Return the disposable object that cleans up - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter, projectDirectory) + use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.Parameter) let tcImports = try @@ -1407,7 +1412,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // of the partial build to be re-evaluated. disposeCleanupItem() - let tcImports = TcImports.BuildNonFrameworkTcImports(tcConfigP,tcGlobals,frameworkTcImports,nonFrameworkResolutions,unresolvedReferences) + let tcImports = TcImports.BuildNonFrameworkTcImports(ctok, tcConfigP, tcGlobals, frameworkTcImports, nonFrameworkResolutions, unresolvedReferences) #if EXTENSIONTYPING for ccu in tcImports.GetCcusExcludingBase() do // When a CCU reports an invalidation, merge them together and just report a @@ -1453,7 +1458,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a Vector.ScanLeft /// /// Type check all files. - let TypeCheckTask (tcAcc:TypeCheckAccumulator) input: Eventually = + let TypeCheckTask ctok (tcAcc:TypeCheckAccumulator) input: Eventually = assertNotDisposed() match input with | Some input, _sourceRange, filename, parseErrors-> @@ -1464,23 +1469,27 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig eventually { beforeFileChecked.Trigger (filename) - ApplyMetaCommandsFromInputToTcConfig tcConfig (input, Path.GetDirectoryName filename) |> ignore + ApplyMetaCommandsFromInputToTcConfig (tcConfig, input, Path.GetDirectoryName filename) |> ignore let sink = TcResultsSinkImpl(tcAcc.tcGlobals) let hadParseErrors = not (List.isEmpty parseErrors) let! (tcEnvAtEndOfFile,topAttribs,typedImplFiles),tcState = - TypeCheckOneInputEventually ((fun () -> hadParseErrors || errorLogger.ErrorCount > 0), - tcConfig,tcAcc.tcImports, - tcAcc.tcGlobals, - None, - TcResultsSink.WithSink sink, - tcAcc.tcState,input) + TypeCheckOneInputEventually + ((fun () -> hadParseErrors || errorLogger.ErrorCount > 0), + tcConfig,tcAcc.tcImports, + tcAcc.tcGlobals, + None, + TcResultsSink.WithSink sink, + tcAcc.tcState,input) /// Only keep the typed interface files when doing a "full" build for fsc.exe, otherwise just throw them away let typedImplFiles = if keepAssemblyContents then typedImplFiles else [] let tcResolutions = if keepAllBackgroundResolutions then sink.GetResolutions() else TcResolutions.Empty let tcEnvAtEndOfFile = (if keepAllBackgroundResolutions then tcEnvAtEndOfFile else tcState.TcEnvFromImpls) let tcSymbolUses = sink.GetSymbolUses() + + RequireCompilationThread ctok // Note: events get raised on the CompilationThread + fileChecked.Trigger (filename) return {tcAcc with tcState=tcState tcEnvAtEndOfFile=tcEnvAtEndOfFile @@ -1495,21 +1504,17 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // return a new Eventually<_> computation which recursively runs more of the computation. // - When the whole thing is finished commit the error results sent through the errorLogger. // - Each time we do real work we reinstall the CompilationGlobalsScope - if ensureReactive then - let timeSlicedComputation = + let timeSlicedComputation = fullComputation |> - Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled + Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled maxTimeShareMilliseconds CancellationToken.None - (fun f -> + (fun ctok f -> // Reinstall the compilation globals each time we start or restart - use unwind = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck, projectDirectory) - f()) + use unwind = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck) + f ctok) - timeSlicedComputation - else - use unwind = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck, projectDirectory) - fullComputation |> Eventually.force |> Eventually.Done + timeSlicedComputation | _ -> Eventually.Done tcAcc @@ -1517,10 +1522,12 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a Vector.Demultiplex /// /// Finish up the typechecking to produce outputs for the rest of the compilation process - let FinalizeTypeCheckTask (tcStates:TypeCheckAccumulator[]) = + let FinalizeTypeCheckTask ctok (tcStates:TypeCheckAccumulator[]) = assertNotDisposed() + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + let errorLogger = CompilationErrorLogger("CombineImportedAssembliesTask", tcConfig) - use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.TypeCheck, projectDirectory) + use _holder = new CompilationGlobalsScope(errorLogger, BuildPhase.TypeCheck) // Get the state at the end of the type-checking of the last file let finalAcc = tcStates.[tcStates.Length-1] @@ -1529,7 +1536,6 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig let (_tcEnvAtEndOfLastFile,topAttrs,mimpls),tcState = let results = tcStates |> List.ofArray |> List.map (fun acc-> acc.tcEnvAtEndOfFile, defaultArg acc.topAttribs EmptyTopAttrs, acc.typedImplFiles) TypeCheckMultipleInputsFinish (results,finalAcc.tcState) - let ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt = try @@ -1607,7 +1613,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig let parseTreesNode = Vector.Map "ParseTrees" ParseTask stampedFileNamesNode let tcStatesNode = Vector.ScanLeft "TypeCheckingStates" TypeCheckTask initialTcAccNode stampedFileNamesNode #else - let tcStatesNode = Vector.ScanLeft "TypeCheckingStates" (fun tcAcc n -> TypeCheckTask tcAcc (ParseTask n)) initialTcAccNode stampedFileNamesNode + let tcStatesNode = Vector.ScanLeft "TypeCheckingStates" (fun ctok tcAcc n -> TypeCheckTask ctok tcAcc (ParseTask ctok n)) initialTcAccNode stampedFileNamesNode #endif let finalizedTypeCheckNode = Vector.Demultiplex "FinalizeTypeCheck" FinalizeTypeCheckTask tcStatesNode @@ -1648,10 +1654,12 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // This is the initial representation of progress through the build, i.e. we have made no progress. let mutable partialBuild = buildDescription.GetInitialPartialBuild buildInputs - let SavePartialBuild b = partialBuild <- b + let SavePartialBuild (ctok: CompilationThreadToken) b = + RequireCompilationThread ctok // modifying state + partialBuild <- b - let MaxTimeStampInDependencies (output:INode) = - IncrementalBuild.MaxTimeStampInDependencies output.Name partialBuild + let MaxTimeStampInDependencies (ctok: CompilationThreadToken) (output:INode) = + IncrementalBuild.MaxTimeStampInDependencies ctok output.Name partialBuild member this.IncrementUsageCount() = assertNotDisposed() @@ -1685,16 +1693,16 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig | _ -> true #endif - member __.Step (ct) = - match IncrementalBuild.Step SavePartialBuild ct (Target(tcStatesNode, None)) partialBuild with + member __.Step (ctok: CompilationThreadToken, ct) = + match IncrementalBuild.Step ctok SavePartialBuild ct (Target(tcStatesNode, None)) partialBuild with | None -> projectChecked.Trigger() false | Some _ -> true - member ib.GetCheckResultsBeforeFileInProjectIfReady (filename): PartialCheckResults option = - let slotOfFile = ib.GetSlotOfFileName filename + member builder.GetCheckResultsBeforeFileInProjectIfReady (filename): PartialCheckResults option = + let slotOfFile = builder.GetSlotOfFileName filename let result = match slotOfFile with | (*first file*) 0 -> GetScalarResult(initialTcAccNode,partialBuild) @@ -1705,47 +1713,47 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig | _ -> None - member ib.AreCheckResultsBeforeFileInProjectReady filename = - let slotOfFile = ib.GetSlotOfFileName filename + member builder.AreCheckResultsBeforeFileInProjectReady (filename) = + let slotOfFile = builder.GetSlotOfFileName filename match slotOfFile with | (*first file*) 0 -> IncrementalBuild.IsReady (Target(initialTcAccNode, None)) partialBuild | _ -> IncrementalBuild.IsReady (Target(tcStatesNode, Some (slotOfFile-1))) partialBuild - member ib.GetCheckResultsBeforeFileInProject (filename, ct) = - let slotOfFile = ib.GetSlotOfFileName filename - ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct) + member builder.GetCheckResultsBeforeFileInProject (ctok: CompilationThreadToken, filename, ct) = + let slotOfFile = builder.GetSlotOfFileName filename + builder.GetCheckResultsBeforeSlotInProject (ctok, slotOfFile, ct) - member ib.GetCheckResultsAfterFileInProject (filename, ct) = - let slotOfFile = ib.GetSlotOfFileName filename + 1 - ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct) + member builder.GetCheckResultsAfterFileInProject (ctok: CompilationThreadToken, filename, ct) = + let slotOfFile = builder.GetSlotOfFileName filename + 1 + builder.GetCheckResultsBeforeSlotInProject (ctok, slotOfFile, ct) - member ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct) = + member builder.GetCheckResultsBeforeSlotInProject (ctok: CompilationThreadToken, slotOfFile, ct) = let result = match slotOfFile with | (*first file*) 0 -> - let build = IncrementalBuild.Eval SavePartialBuild ct initialTcAccNode partialBuild + let build = IncrementalBuild.Eval ctok SavePartialBuild ct initialTcAccNode partialBuild GetScalarResult(initialTcAccNode,build) | _ -> - let build = IncrementalBuild.EvalUpTo SavePartialBuild ct (tcStatesNode, (slotOfFile-1)) partialBuild + let build = IncrementalBuild.EvalUpTo ctok SavePartialBuild ct (tcStatesNode, (slotOfFile-1)) partialBuild GetVectorResultBySlot(tcStatesNode,slotOfFile-1,build) match result with | Some (tcAcc,timestamp) -> PartialCheckResults.Create (tcAcc,timestamp) | None -> failwith "Build was not evaluated, expected the results to be ready after 'Eval'." - member b.GetCheckResultsAfterLastFileInProject (ct) = - b.GetTypeCheckResultsBeforeSlotInProject(b.GetSlotsCount(), ct) + member builder.GetCheckResultsAfterLastFileInProject (ctok: CompilationThreadToken, ct) = + builder.GetCheckResultsBeforeSlotInProject(ctok, builder.GetSlotsCount(), ct) - member __.GetCheckResultsAndImplementationsForProject(ct) = - let build = IncrementalBuild.Eval SavePartialBuild ct finalizedTypeCheckNode partialBuild + member __.GetCheckResultsAndImplementationsForProject(ctok: CompilationThreadToken, ct) = + let build = IncrementalBuild.Eval ctok SavePartialBuild ct finalizedTypeCheckNode partialBuild match GetScalarResult(finalizedTypeCheckNode,build) with | Some ((ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt, tcAcc), timestamp) -> PartialCheckResults.Create (tcAcc,timestamp), ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt | None -> failwith "Build was not evaluated, expcted the results to be ready after 'Eval'." - member __.GetLogicalTimeStampForProject() = - let t1 = MaxTimeStampInDependencies stampedFileNamesNode - let t2 = MaxTimeStampInDependencies stampedReferencedAssembliesNode + member __.GetLogicalTimeStampForProject(ctok: CompilationThreadToken) = + let t1 = MaxTimeStampInDependencies ctok stampedFileNamesNode + let t2 = MaxTimeStampInDependencies ctok stampedReferencedAssembliesNode max t1 t2 member __.GetSlotOfFileName(filename:string) = @@ -1765,13 +1773,13 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig | Some (VectorResult vr) -> vr.Size | _ -> failwith "Failed to find sizes" - member ib.GetParseResultsForFile (filename, ct) = - let slotOfFile = ib.GetSlotOfFileName filename + member builder.GetParseResultsForFile (ctok: CompilationThreadToken, filename, ct) = + let slotOfFile = builder.GetSlotOfFileName filename #if FCS_RETAIN_BACKGROUND_PARSE_RESULTS match GetVectorResultBySlot(parseTreesNode,slotOfFile,partialBuild) with | Some (results, _) -> results | None -> - let build = IncrementalBuild.EvalUpTo SavePartialBuild ct (parseTreesNode, slotOfFile) partialBuild + let build = IncrementalBuild.EvalUpTo ctok SavePartialBuild ct (parseTreesNode, slotOfFile) partialBuild match GetVectorResultBySlot(parseTreesNode,slotOfFile,build) with | Some (results, _) -> results | None -> failwith "Build was not evaluated, expcted the results to be ready after 'Eval'." @@ -1780,19 +1788,19 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig match GetVectorResultBySlot(stampedFileNamesNode,slotOfFile,partialBuild) with | Some (results, _) -> results | None -> - let build = IncrementalBuild.EvalUpTo SavePartialBuild ct (stampedFileNamesNode, slotOfFile) partialBuild + let build = IncrementalBuild.EvalUpTo ctok SavePartialBuild ct (stampedFileNamesNode, slotOfFile) partialBuild match GetVectorResultBySlot(stampedFileNamesNode,slotOfFile,build) with | Some (results, _) -> results | None -> failwith "Build was not evaluated, expcted the results to be ready after 'Eval'." // re-parse on demand instead of retaining - ParseTask results + ParseTask ctok results #endif member __.ProjectFileNames = sourceFiles |> List.map (fun (_,f,_) -> f) /// CreateIncrementalBuilder (for background type checking). Note that fsc.fs also /// creates an incremental builder used by the command line compiler. - static member TryCreateBackgroundBuilderForProjectOptions (referenceResolver, frameworkTcImportsCache, loadClosureOpt:LoadClosure option, sourceFiles:string list, commandLineArgs:string list, projectReferences, projectDirectory, useScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions) = + static member TryCreateBackgroundBuilderForProjectOptions (ctok, referenceResolver, frameworkTcImportsCache, loadClosureOpt:LoadClosure option, sourceFiles:string list, commandLineArgs:string list, projectReferences, projectDirectory, useScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) = // Trap and report warnings and errors from creation. use errorScope = new ErrorScope() @@ -1858,18 +1866,19 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig tcConfigB.knownUnresolvedReferences <- loadClosure.UnresolvedReferences | None -> () - let tcConfig = TcConfig.Create(tcConfigB,validate=true) + let tcConfig = TcConfig.Create(tcConfigB, validate=true) let niceNameGen = NiceNameGenerator() let outfile, _, assemblyName = tcConfigB.DecideNames sourceFilesNew let builder = - new IncrementalBuilder(frameworkTcImportsCache, + new IncrementalBuilder(ctok, frameworkTcImportsCache, tcConfig, projectDirectory, outfile, assemblyName, niceNameGen, - resourceManager, sourceFilesNew, projectReferences, loadClosureOpt, ensureReactive=true, + resourceManager, sourceFilesNew, projectReferences, loadClosureOpt, keepAssemblyContents=keepAssemblyContents, - keepAllBackgroundResolutions=keepAllBackgroundResolutions) + keepAllBackgroundResolutions=keepAllBackgroundResolutions, + maxTimeShareMilliseconds=maxTimeShareMilliseconds) Some builder with e -> errorRecoveryNoRange e @@ -1882,4 +1891,4 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig | Some builder -> builder.IncrementUsageCount() | None -> { new System.IDisposable with member __.Dispose() = () } - member b.IsBeingKeptAliveApartFromCacheEntry = (referenceCount >= 2) + member builder.IsBeingKeptAliveApartFromCacheEntry = (referenceCount >= 2) diff --git a/src/fsharp/vs/IncrementalBuild.fsi b/src/fsharp/vs/IncrementalBuild.fsi index 95b3a21d47..b274bd3e4e 100755 --- a/src/fsharp/vs/IncrementalBuild.fsi +++ b/src/fsharp/vs/IncrementalBuild.fsi @@ -52,9 +52,9 @@ type internal ErrorScope = /// Lookup the global static cache for building the FrameworkTcImports type internal FrameworkImportsCache = new : size: int -> FrameworkImportsCache - member Get : TcConfig -> TcGlobals * TcImports * AssemblyResolution list * UnresolvedAssemblyReference list - member Clear: unit -> unit - member Downsize: unit -> unit + member Get : CompilationThreadToken * TcConfig -> TcGlobals * TcImports * AssemblyResolution list * UnresolvedAssemblyReference list + member Clear: CompilationThreadToken -> unit + member Downsize: CompilationThreadToken -> unit /// Used for unit testing module internal IncrementalBuilderEventTesting = @@ -144,51 +144,55 @@ type internal IncrementalBuilder = member ThereAreLiveTypeProviders : bool #endif /// Perform one step in the F# build. Return true if the background work is finished. - member Step : ct: CancellationToken -> bool + member Step : CompilationThreadToken * ct: CancellationToken -> bool /// Get the preceding typecheck state of a slot, without checking if it is up-to-date w.r.t. /// the timestamps on files and referenced DLLs prior to this one. Return None if the result is not available. /// This is a very quick operation. + /// + /// This is safe for use from non-compiler threads but the objects returned must in many cases be accessed only from the compiler thread. member GetCheckResultsBeforeFileInProjectIfReady: filename:string -> PartialCheckResults option /// Get the preceding typecheck state of a slot, but only if it is up-to-date w.r.t. /// the timestamps on files and referenced DLLs prior to this one. Return None if the result is not available. /// This is a relatively quick operation. + /// + /// This is safe for use from non-compiler threads member AreCheckResultsBeforeFileInProjectReady: filename:string -> bool /// Get the preceding typecheck state of a slot. Compute the entire type check of the project up /// to the necessary point if the result is not available. This may be a long-running operation. /// // TODO: make this an Eventually (which can be scheduled) or an Async (which can be cancelled) - member GetCheckResultsBeforeFileInProject : filename:string * ct: CancellationToken -> PartialCheckResults + member GetCheckResultsBeforeFileInProject : CompilationThreadToken * filename:string * ct: CancellationToken -> PartialCheckResults /// Get the typecheck state after checking a file. Compute the entire type check of the project up /// to the necessary point if the result is not available. This may be a long-running operation. /// // TODO: make this an Eventually (which can be scheduled) or an Async (which can be cancelled) - member GetCheckResultsAfterFileInProject : filename:string * ct: CancellationToken -> PartialCheckResults + member GetCheckResultsAfterFileInProject : CompilationThreadToken * filename:string * ct: CancellationToken -> PartialCheckResults /// Get the typecheck result after the end of the last file. The typecheck of the project is not 'completed'. /// This may be a long-running operation. /// // TODO: make this an Eventually (which can be scheduled) or an Async (which can be cancelled) - member GetCheckResultsAfterLastFileInProject : ct: CancellationToken -> PartialCheckResults + member GetCheckResultsAfterLastFileInProject : CompilationThreadToken * ct: CancellationToken -> PartialCheckResults /// Get the final typecheck result. If 'generateTypedImplFiles' was set on Create then the TypedAssemblyAfterOptimization will contain implementations. /// This may be a long-running operation. /// // TODO: make this an Eventually (which can be scheduled) or an Async (which can be cancelled) - member GetCheckResultsAndImplementationsForProject : ct: CancellationToken -> PartialCheckResults * IL.ILAssemblyRef * IRawFSharpAssemblyData option * TypedImplFile list option + member GetCheckResultsAndImplementationsForProject : CompilationThreadToken * ct: CancellationToken -> PartialCheckResults * IL.ILAssemblyRef * IRawFSharpAssemblyData option * TypedImplFile list option /// Get the logical time stamp that is associated with the output of the project if it were gully built immediately - member GetLogicalTimeStampForProject: unit -> DateTime + member GetLogicalTimeStampForProject: CompilationThreadToken -> DateTime /// Await the untyped parse results for a particular slot in the vector of parse results. /// /// This may be a marginally long-running operation (parses are relatively quick, only one file needs to be parsed) - member GetParseResultsForFile : filename:string * ct: CancellationToken -> Ast.ParsedInput option * Range.range * string * (PhasedDiagnostic * FSharpErrorSeverity) list + member GetParseResultsForFile : CompilationThreadToken * filename:string * ct: CancellationToken -> Ast.ParsedInput option * Range.range * string * (PhasedDiagnostic * FSharpErrorSeverity) list - static member TryCreateBackgroundBuilderForProjectOptions : ReferenceResolver.Resolver * FrameworkImportsCache * scriptClosureOptions:LoadClosure option * sourceFiles:string list * commandLineArgs:string list * projectReferences: IProjectReference list * projectDirectory:string * useScriptResolutionRules:bool * keepAssemblyContents: bool * keepAllBackgroundResolutions: bool -> IncrementalBuilder option * FSharpErrorInfo list + static member TryCreateBackgroundBuilderForProjectOptions : CompilationThreadToken * ReferenceResolver.Resolver * FrameworkImportsCache * scriptClosureOptions:LoadClosure option * sourceFiles:string list * commandLineArgs:string list * projectReferences: IProjectReference list * projectDirectory:string * useScriptResolutionRules:bool * keepAssemblyContents: bool * keepAllBackgroundResolutions: bool * maxTimeShareMilliseconds: int64 -> IncrementalBuilder option * FSharpErrorInfo list static member KeepBuilderAlive : IncrementalBuilder option -> IDisposable member IsBeingKeptAliveApartFromCacheEntry : bool @@ -230,15 +234,15 @@ module internal IncrementalBuild = /// Only required for unit testing. module Vector = /// Maps one vector to another using the given function. - val Map : string -> ('I -> 'O) -> Vector<'I> -> Vector<'O> + val Map : string -> (CompilationThreadToken -> 'I -> 'O) -> Vector<'I> -> Vector<'O> /// Updates the creates a new vector with the same items but with /// timestamp specified by the passed-in function. - val Stamp : string -> ('I -> System.DateTime) -> Vector<'I> -> Vector<'I> + val Stamp : string -> (CompilationThreadToken -> 'I -> System.DateTime) -> Vector<'I> -> Vector<'I> /// Apply a function to each element of the vector, threading an accumulator argument /// through the computation. Returns intermediate results in a vector. - val ScanLeft : string -> ('A -> 'I -> Eventually<'A>) -> Scalar<'A> -> Vector<'I> -> Vector<'A> + val ScanLeft : string -> (CompilationThreadToken -> 'A -> 'I -> Eventually<'A>) -> Scalar<'A> -> Vector<'I> -> Vector<'A> /// Apply a function to a vector to get a scalar value. - val Demultiplex : string -> ('I[] -> 'O)->Vector<'I> -> Scalar<'O> + val Demultiplex : string -> (CompilationThreadToken -> 'I[] -> 'O)->Vector<'I> -> Scalar<'O> /// Convert a Vector into a Scalar. val AsScalar: string -> Vector<'I> -> Scalar<'I[]> @@ -248,13 +252,13 @@ module internal IncrementalBuild = val LocallyInjectCancellationFault : unit -> IDisposable /// Evaluate a build. Only required for unit testing. - val Eval : (PartialBuild -> unit) -> CancellationToken -> INode -> PartialBuild -> PartialBuild + val Eval : CompilationThreadToken -> (CompilationThreadToken -> PartialBuild -> unit) -> CancellationToken -> INode -> PartialBuild -> PartialBuild /// Evaluate a build for a vector up to a limit. Only required for unit testing. - val EvalUpTo : (PartialBuild -> unit) -> CancellationToken -> INode * int -> PartialBuild -> PartialBuild + val EvalUpTo : CompilationThreadToken -> (CompilationThreadToken -> PartialBuild -> unit) -> CancellationToken -> INode * int -> PartialBuild -> PartialBuild /// Do one step in the build. Only required for unit testing. - val Step : (PartialBuild -> unit) -> CancellationToken -> Target -> PartialBuild -> PartialBuild option + val Step : CompilationThreadToken -> (CompilationThreadToken -> PartialBuild -> unit) -> CancellationToken -> Target -> PartialBuild -> PartialBuild option /// Get a scalar vector. Result must be available. Only required for unit testing. val GetScalarResult : Scalar<'T> * PartialBuild -> ('T * System.DateTime) option /// Get a result vector. All results must be available or thrown an exception. Only required for unit testing. @@ -283,5 +287,5 @@ module internal IncrementalBuild = /// /// Use to reset error and warning handlers. type internal CompilationGlobalsScope = - new : ErrorLogger * BuildPhase * string -> CompilationGlobalsScope + new : ErrorLogger * BuildPhase -> CompilationGlobalsScope interface IDisposable \ No newline at end of file diff --git a/src/fsharp/vs/Reactor.fs b/src/fsharp/vs/Reactor.fs index 47d7951809..3c98ce857d 100755 --- a/src/fsharp/vs/Reactor.fs +++ b/src/fsharp/vs/Reactor.fs @@ -8,18 +8,20 @@ open System.Threading open Microsoft.FSharp.Control open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// Represents the capability to schedule work in the compiler service operations queue for the compilation thread type internal IReactorOperations = - abstract EnqueueAndAwaitOpAsync : string * (CancellationToken -> 'T) -> Async<'T> - abstract EnqueueOp: string * (unit -> unit) -> unit + abstract EnqueueAndAwaitOpAsync : string * (CompilationThreadToken -> CancellationToken -> 'T) -> Async<'T> + abstract EnqueueOp: string * (CompilationThreadToken -> unit) -> unit [] type internal ReactorCommands = /// Kick off a build. - | SetBackgroundOp of (unit -> bool) option + | SetBackgroundOp of (CompilationThreadToken -> bool) option /// Do some work not synchronized in the mailbox. - | Op of string * CancellationToken * (unit -> unit) * (unit -> unit) + | Op of string * CancellationToken * (CompilationThreadToken -> unit) * (unit -> unit) /// Finish the background building | WaitForBackgroundOpCompletion of AsyncReplyChannel /// Finish all the queued ops @@ -45,6 +47,9 @@ type Reactor() = let rec loop (bgOpOpt, onComplete, bg) = async { Trace.TraceInformation("Reactor: receiving..., remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2)) + // Explanation: The reactor thread acts as the compilation thread in hosted scenarios + let ctok = AssumeCompilationThreadWithoutEvidence() + // Messages always have priority over the background op. let! msg = async { match bgOpOpt, onComplete with @@ -69,7 +74,7 @@ type Reactor() = if ct.IsCancellationRequested then ccont() else Trace.TraceInformation("Reactor: --> {0}, remaining {1}, mem {2}, gc2 {3}", desc, inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2)) let time = System.DateTime.Now - op() + op ctok let span = System.DateTime.Now - time //if span.TotalMilliseconds > 100.0 then Trace.TraceInformation("Reactor: <-- {0}, remaining {1}, took {2}ms", desc, inbox.CurrentQueueLength, span.TotalMilliseconds) @@ -78,7 +83,9 @@ type Reactor() = Trace.TraceInformation("Reactor: --> wait for background (debug only), remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2)) match bgOpOpt with | None -> () - | Some bgOp -> while bgOp() do () + | Some bgOp -> + while bgOp ctok do + () channel.Reply(()) return! loop (None, onComplete, false) | Some (CompleteAllQueuedOps channel) -> @@ -90,7 +97,7 @@ type Reactor() = | Some bgOp, None -> Trace.TraceInformation("Reactor: --> background step, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2)) let time = System.DateTime.Now - let res = bgOp() + let res = bgOp ctok let span = System.DateTime.Now - time //if span.TotalMilliseconds > 100.0 then Trace.TraceInformation("Reactor: <-- background step, remaining {0}, took {1}ms", inbox.CurrentQueueLength, span.TotalMilliseconds) @@ -136,10 +143,10 @@ type Reactor() = let! ct = Async.CancellationToken let resultCell = AsyncUtil.AsyncResultCell<_>() r.EnqueueOpPrim(desc, ct, - op=(fun () -> + op=(fun ctok -> let result = try - f ct |> AsyncUtil.AsyncOk + f ctok ct |> AsyncUtil.AsyncOk with | :? OperationCanceledException as e -> AsyncUtil.AsyncCanceled e | e -> e |> AsyncUtil.AsyncException diff --git a/src/fsharp/vs/Reactor.fsi b/src/fsharp/vs/Reactor.fsi index 2732113489..a90ad8d021 100755 --- a/src/fsharp/vs/Reactor.fsi +++ b/src/fsharp/vs/Reactor.fsi @@ -3,15 +3,17 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open System.Threading +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// Represents the capability to schedule work in the compiler service operations queue for the compilation thread type internal IReactorOperations = /// Put the operation in thq queue, and return an async handle to its result. - abstract EnqueueAndAwaitOpAsync : description: string * action: (CancellationToken -> 'T) -> Async<'T> + abstract EnqueueAndAwaitOpAsync : description: string * action: (CompilationThreadToken -> CancellationToken -> 'T) -> Async<'T> /// Enqueue an operation and return immediately. - abstract EnqueueOp: description: string * action: (unit -> unit) -> unit + abstract EnqueueOp: description: string * action: (CompilationThreadToken -> unit) -> unit /// Reactor is intended for long-running but interruptible operations, interleaved /// with one-off asynchronous operations. @@ -24,7 +26,7 @@ type internal Reactor = /// Set the background building function, which is called repeatedly /// until it returns 'false'. If None then no background operation is used. - member SetBackgroundOp : build:(unit -> bool) option -> unit + member SetBackgroundOp : build:(CompilationThreadToken -> bool) option -> unit /// Block until the current implicit background build is complete. Unit test only. member WaitForBackgroundOpCompletion : unit -> unit @@ -33,13 +35,13 @@ type internal Reactor = member CompleteAllQueuedOps : unit -> unit /// Enqueue an uncancellable operation and return immediately. - member EnqueueOp : description: string * op:(unit -> unit) -> unit + member EnqueueOp : description: string * op:(CompilationThreadToken -> unit) -> unit /// For debug purposes member CurrentQueueLength : int /// Put the operation in the queue, and return an async handle to its result. - member EnqueueAndAwaitOpAsync : description: string * (CancellationToken -> 'T) -> Async<'T> + member EnqueueAndAwaitOpAsync : description: string * (CompilationThreadToken -> CancellationToken -> 'T) -> Async<'T> /// The timespan in milliseconds before background work begins after the operations queue is empty member PauseBeforeBackgroundWork : int with get, set diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/vs/ServiceDeclarations.fs index 57ceedd6e1..adeb19d005 100644 --- a/src/fsharp/vs/ServiceDeclarations.fs +++ b/src/fsharp/vs/ServiceDeclarations.fs @@ -1310,7 +1310,8 @@ type FSharpDeclarationListItem(name: string, nameInCode: string, glyphMajor: Gly match info with | Choice1Of2 (items, infoReader, m, denv, reactor:IReactorOperations, checkAlive) -> // reactor causes the lambda to execute on the background compiler thread, through the Reactor - reactor.EnqueueAndAwaitOpAsync ("StructuredDescriptionTextAsync", fun _ct -> + reactor.EnqueueAndAwaitOpAsync ("StructuredDescriptionTextAsync", fun ctok _ct -> + RequireCompilationThread ctok // This is where we do some work which may touch TAST data structures owned by the IncrementalBuilder - infoReader, item etc. // It is written to be robust to a disposal of an IncrementalBuilder, in which case it will just return the empty string. // It is best to think of this as a "weak reference" to the IncrementalBuilder, i.e. this code is written to be robust to its diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs index 3e4ec2a6e0..9eb09124ea 100755 --- a/src/fsharp/vs/ServiceLexing.fs +++ b/src/fsharp/vs/ServiceLexing.fs @@ -10,6 +10,7 @@ open System open System.IO open System.Collections.Generic open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Parser @@ -554,7 +555,8 @@ type FSharpLineTokenizer(lexbuf: UnicodeLexing.Lexbuf, | Some(value) -> resetLexbufPos value lexbuf member x.ScanToken(lexintInitial) : Option * FSharpTokenizerLexState = - use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _ -> DiscardErrorsLogger) let lightSyntaxStatusInital, lexcontInitial = LexerStateEncoding.decodeLexInt lexintInitial diff --git a/src/fsharp/vs/ServiceUntypedParse.fs b/src/fsharp/vs/ServiceUntypedParse.fs index d78722db94..8e4c3f3b3d 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fs +++ b/src/fsharp/vs/ServiceUntypedParse.fs @@ -94,8 +94,7 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput /// Get declared items and the selected item at the specified location member private scope.GetNavigationItemsImpl() = - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 (fun () -> match input with | Some(ParsedInput.ImplFile(ParsedImplFileInput(_modname,_isScript,_qualName,_pragmas,_hashDirectives,modules,_isLastCompiland))) -> @@ -347,8 +346,7 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput | Some(ParsedInput.ImplFile(ParsedImplFileInput(_,_,_,_,_,modules,_))) -> walkImplFile modules | _ -> [] - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 (fun () -> let locations = findBreakPoints() diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs index 42ee580831..9dc3104a56 100644 --- a/src/fsharp/vs/service.fs +++ b/src/fsharp/vs/service.fs @@ -11,6 +11,7 @@ open System.Text open System.Threading open System.Runtime open System.Collections.Generic +open System.Collections.Concurrent open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler @@ -59,6 +60,15 @@ module EnvMisc = let maxMBDefault = GetEnvInteger "FCS_MaxMB" 1000000 // a million MB = 1TB = disabled //let maxMBDefault = GetEnvInteger "FCS_maxMB" (if sizeof = 4 then 1700 else 3400) + /// Maximum time share for a piece of background work before it should (cooperatively) yield + /// to enable other requests to be serviced. Yielding means returning a continuation function + /// (via an Eventually<_> value of case NotYetDone) that can be called as the next piece of work. + let maxTimeShareMilliseconds = + match System.Environment.GetEnvironmentVariable("FCS_MaxTimeShare") with + | null | "" -> 50L + | s -> int64 s + + //---------------------------------------------------------------------------- // Methods //-------------------------------------------------------------------------- @@ -525,7 +535,7 @@ type TypeCheckInfo // Is not keyed on 'Names' collection because this is invariant for the current position in // this unchanged file. Keyed on lineStr though to prevent a change to the currently line // being available against a stale scope. - let getToolTipTextCache = AgedLookup>(getToolTipTextSize,areSame=(fun (x,y) -> x = y)) + let getToolTipTextCache = AgedLookup>(getToolTipTextSize,areSame=(fun (x,y) -> x = y)) let amap = tcImports.GetImportMap() let infoReader = new InfoReader(g,amap) @@ -1007,7 +1017,8 @@ type TypeCheckInfo /// Get the auto-complete items at a particular location. - let GetDeclItemsForNamesAtPosition(parseResultsOpt: FSharpParseFileResults option, origLongIdentOpt: string list option, residueOpt:string option, line:int, lineStr:string, colAtEndOfNamesAndResidue, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) = + let GetDeclItemsForNamesAtPosition(ctok: CompilationThreadToken, parseResultsOpt: FSharpParseFileResults option, origLongIdentOpt: string list option, residueOpt:string option, line:int, lineStr:string, colAtEndOfNamesAndResidue, filterCtors, resolveOverloads, hasTextChangedSinceLastTypecheck: (obj * range -> bool)) = + RequireCompilationThread ctok // the operations in this method need the reactor thread let loc = match colAtEndOfNamesAndResidue with @@ -1138,12 +1149,11 @@ type TypeCheckInfo items |> List.exists (ItemsAreEffectivelyEqual g item) /// Get the auto-complete items at a location - member x.GetDeclarations (parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck) = + member x.GetDeclarations (ctok, parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck) = let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 (fun () -> - match GetDeclItemsForNamesAtPosition(parseResultsOpt, Some qualifyingNames, Some partialName, line, lineStr, colAtEndOfNamesAndResidue, ResolveTypeNamesToCtors, ResolveOverloads.Yes, hasTextChangedSinceLastTypecheck) with + match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some qualifyingNames, Some partialName, line, lineStr, colAtEndOfNamesAndResidue, ResolveTypeNamesToCtors, ResolveOverloads.Yes, hasTextChangedSinceLastTypecheck) with | None -> FSharpDeclarationListInfo.Empty | Some (items, denv, m) -> let items = items |> FilterAutoCompletesBasedOnParseContext parseResultsOpt (mkPos line colAtEndOfNamesAndResidue) @@ -1152,12 +1162,11 @@ type TypeCheckInfo (fun msg -> FSharpDeclarationListInfo.Error msg) /// Get the symbols for auto-complete items at a location - member x.GetDeclarationListSymbols (parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck) = + member x.GetDeclarationListSymbols (ctok, parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck) = let isInterfaceFile = SourceFileImpl.IsInterfaceFile mainInputFileName - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 (fun () -> - match GetDeclItemsForNamesAtPosition(parseResultsOpt, Some qualifyingNames, Some partialName, line, lineStr, colAtEndOfNamesAndResidue, ResolveTypeNamesToCtors, ResolveOverloads.Yes, hasTextChangedSinceLastTypecheck) with + match GetDeclItemsForNamesAtPosition(ctok, parseResultsOpt, Some qualifyingNames, Some partialName, line, lineStr, colAtEndOfNamesAndResidue, ResolveTypeNamesToCtors, ResolveOverloads.Yes, hasTextChangedSinceLastTypecheck) with | None -> List.Empty | Some (items, _denv, _m) -> let items = items |> FilterAutoCompletesBasedOnParseContext parseResultsOpt (mkPos line colAtEndOfNamesAndResidue) @@ -1220,7 +1229,10 @@ type TypeCheckInfo (fun _msg -> []) /// Get the "reference resolution" tooltip for at a location - member scope.GetReferenceResolutionStructuredToolTipText(line,col) = + member scope.GetReferenceResolutionStructuredToolTipText(ctok, line,col) = + + RequireCompilationThread ctok // the operations in this method need the reactor thread but the reasons why are not yet grounded + let pos = mkPos line col let isPosMatch(pos, ar:AssemblyReference) : bool = let isRangeMatch = (Range.rangeContainsPos ar.Range pos) @@ -1246,18 +1258,16 @@ type TypeCheckInfo | [] -> FSharpStructuredToolTipText.FSharpToolTipText [] - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 dataTipOfReferences (fun err -> FSharpToolTipText [FSharpStructuredToolTipElement.CompositionError err]) // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. - member x.GetStructuredToolTipText line lineStr colAtEndOfNames names = + member x.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names) = let Compute() = - ErrorScope.Protect - Range.range0 + ErrorScope.Protect Range.range0 (fun () -> - match GetDeclItemsForNamesAtPosition(None,Some(names),None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.Yes,fun _ -> false) with + match GetDeclItemsForNamesAtPosition(ctok, None,Some(names),None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.Yes,fun _ -> false) with | None -> FSharpToolTipText [] | Some(items, denv, m) -> FSharpToolTipText(items |> List.map (FormatStructuredDescriptionOfItem false infoReader m denv ))) @@ -1265,23 +1275,22 @@ type TypeCheckInfo // See devdiv bug 646520 for rationale behind truncating and caching these quick infos (they can be big!) let key = line,colAtEndOfNames,lineStr - match getToolTipTextCache.TryGet key with + match getToolTipTextCache.TryGet (ctok, key) with | Some res -> res | None -> let res = Compute() - getToolTipTextCache.Put(key,res) + getToolTipTextCache.Put(ctok, key,res) res // GetToolTipText: return the "pop up" (or "Quick Info") text given a certain context. - member x.GetToolTipText line lineStr colAtEndOfNames names = - x.GetStructuredToolTipText line lineStr colAtEndOfNames names + member x.GetToolTipText ctok line lineStr colAtEndOfNames names = + x.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names) |> Tooltips.ToFSharpToolTipText - member x.GetF1Keyword (line, lineStr, colAtEndOfNames, names) : string option = - ErrorScope.Protect - Range.range0 + member x.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names) : string option = + ErrorScope.Protect Range.range0 (fun () -> - match GetDeclItemsForNamesAtPosition(None, Some names, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No, fun _ -> false) with // F1 Keywords do not distiguish between overloads + match GetDeclItemsForNamesAtPosition(ctok, None, Some names, None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No, fun _ -> false) with // F1 Keywords do not distiguish between overloads | None -> None | Some (items, _, _) -> match items with @@ -1308,18 +1317,17 @@ type TypeCheckInfo ) (fun _ -> None) - member scope.GetMethods (line, lineStr, colAtEndOfNames, namesOpt) = - ErrorScope.Protect - Range.range0 + member scope.GetMethods (ctok, line, lineStr, colAtEndOfNames, namesOpt) = + ErrorScope.Protect Range.range0 (fun () -> - match GetDeclItemsForNamesAtPosition(None,namesOpt,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.No, fun _ -> false) with + match GetDeclItemsForNamesAtPosition(ctok, None,namesOpt,None,line,lineStr,colAtEndOfNames,ResolveTypeNamesToCtors,ResolveOverloads.No, fun _ -> false) with | None -> FSharpMethodGroup("",[| |]) | Some (items, denv, m) -> FSharpMethodGroup.Create(infoReader,m,denv,items)) (fun msg -> FSharpMethodGroup(msg,[| |])) - member scope.GetMethodsAsSymbols (line, lineStr, colAtEndOfNames, names) = - match GetDeclItemsForNamesAtPosition (None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No, fun _ -> false) with + member scope.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) = + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.No, fun _ -> false) with | None | Some ([], _, _) -> None | Some (items, denv, m) -> let allItems = @@ -1351,8 +1359,8 @@ type TypeCheckInfo let symbols = allItems |> List.map (fun item -> FSharpSymbol.Create(g, thisCcu, tcImports, item)) Some (symbols, denv, m) - member scope.GetDeclarationLocation (line, lineStr, colAtEndOfNames, names, preferFlag) = - match GetDeclItemsForNamesAtPosition (None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors,ResolveOverloads.Yes, fun _ -> false) with + member scope.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag) = + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors,ResolveOverloads.Yes, fun _ -> false) with | None | Some ([], _, _) -> FSharpFindDeclResult.DeclNotFound FSharpFindDeclFailureReason.Unknown | Some (item :: _ , _, _) -> @@ -1393,8 +1401,8 @@ type TypeCheckInfo else fail FSharpFindDeclFailureReason.NoSourceCode // provided items may have TypeProviderDefinitionLocationAttribute that binds them to some location - member scope.GetSymbolUseAtLocation (line, lineStr, colAtEndOfNames, names) = - match GetDeclItemsForNamesAtPosition (None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.Yes, fun _ -> false) with + member scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) = + match GetDeclItemsForNamesAtPosition (ctok, None,Some(names), None, line, lineStr, colAtEndOfNames, ResolveTypeNamesToCtors, ResolveOverloads.Yes, fun _ -> false) with | None | Some ([], _, _) -> None | Some (item :: _ , denv, m) -> let symbol = FSharpSymbol.Create(g, thisCcu, tcImports, item) @@ -1570,7 +1578,12 @@ module internal Parser = /// ParseOneFile builds all the information necessary to report errors, match braces and build scopes /// /// projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true. - let ParseOneFile (source: string, matchBracesOnly: bool, reportErrors: bool, mainInputFileName: string, projectSourceFiles: string list, tcConfig: TcConfig) = + let ParseOneFile (ctok, source: string, matchBracesOnly: bool, reportErrors: bool, mainInputFileName: string, projectSourceFiles: string list, tcConfig: TcConfig) = + + // This function requires the compilation thread because we install error handlers, whose callbacks must + // be invoked on the compilation thread, no other reason known to date. + // We should check whether those are "real" reasons - we could for example make collecting errors thread safe. + RequireCompilationThread ctok // Initialize the error handler let errHandler = new ErrorHandler(reportErrors, mainInputFileName, tcConfig, source) @@ -1581,8 +1594,8 @@ module internal Parser = // Collector for parens matching let matchPairRef = new ResizeArray<_>() - use unwindEL = PushErrorLoggerPhaseUntilUnwind(fun _oldLogger -> errHandler.ErrorLogger) - use unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) + use unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) + use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse // Errors on while parsing project arguments @@ -1593,7 +1606,7 @@ module internal Parser = let conditionalCompilationDefines = SourceFileImpl.AdditionalDefinesForUseInEditor(mainInputFileName) @ tcConfig.conditionalCompilationDefines - let lightSyntaxStatusInital = tcConfig.ComputeLightSyntaxInitialStatus mainInputFileName + let lightSyntaxStatusInital = tcConfig.ComputeLightSyntaxInitialStatus (mainInputFileName) let lightSyntaxStatus = LightSyntaxStatus(lightSyntaxStatusInital,true) // Note: we don't really attempt to intern strings across a large scope @@ -1686,12 +1699,12 @@ module internal Parser = | Some parsedMainInput -> // Initialize the error handler let errHandler = new ErrorHandler(true, mainInputFileName, tcConfig, source) - + use _unwindEL = PushErrorLoggerPhaseUntilUnwind (fun _oldLogger -> errHandler.ErrorLogger) - use _unwindBP = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) + use _unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck // Apply nowarns to tcConfig (may generate errors, so ensure errorLogger is installed) - let tcConfig = ApplyNoWarnsToTcConfig tcConfig (parsedMainInput,Path.GetDirectoryName mainInputFileName) + let tcConfig = ApplyNoWarnsToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) // update the error handler with the modified tcConfig errHandler.TcConfig <- tcConfig @@ -1754,7 +1767,7 @@ module internal Parser = | None -> // For non-scripts, check for disallow #r and #load. - ApplyMetaCommandsFromInputToTcConfig tcConfig (parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore + ApplyMetaCommandsFromInputToTcConfig (tcConfig, parsedMainInput,Path.GetDirectoryName mainInputFileName) |> ignore // A problem arises with nice name generation, which really should only // be done in the backend, but is also done in the typechecker for better or worse. @@ -1771,20 +1784,17 @@ module internal Parser = let checkForErrors() = (parseResults.ParseHadErrors || errHandler.ErrorCount > 0) // Typecheck is potentially a long running operation. We chop it up here with an Eventually continuation and, at each slice, give a chance // for the client to claim the result as obsolete and have the typecheck abort. - let projectDir = Path.GetDirectoryName(projectFileName) - let capturingErrorLogger = CompilationErrorLogger("TypeCheckOneFile", tcConfig) - let errorLogger = GetErrorLoggerFilteringByScopedPragmas(false,GetScopedPragmasForInput(parsedMainInput), capturingErrorLogger) let! result = - TypeCheckOneInputAndFinishEventually(checkForErrors,tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) - |> Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled 50L ct (fun f -> f()) - |> Eventually.forceAsync - (fun (work: unit -> Eventually<_>) -> + TypeCheckOneInputAndFinishEventually(checkForErrors, tcConfig, tcImports, tcGlobals, None, TcResultsSink.WithSink sink, tcState, parsedMainInput) + |> Eventually.repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled maxTimeShareMilliseconds ct (fun ctok f -> f ctok) + |> Eventually.forceAsync + (fun work -> reactorOps.EnqueueAndAwaitOpAsync("TypeCheckOneFile", - fun _ -> + fun ctok _ -> // Reinstall the compilation globals each time we start or restart - use unwind = new CompilationGlobalsScope (errorLogger, BuildPhase.TypeCheck, projectDir) - work())) + use unwind = new CompilationGlobalsScope (errHandler.ErrorLogger, BuildPhase.TypeCheck) + work ctok)) return result |> Option.map (fun ((tcEnvAtEnd, _, typedImplFiles), tcState) -> tcEnvAtEnd, typedImplFiles, tcState) with @@ -1909,7 +1919,9 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], member info.GetUsesOfSymbol(symbol:FSharpSymbol) = let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() // This probably doesn't need to be run on the reactor since all data touched by GetUsesOfSymbol is immutable. - reactorOps.EnqueueAndAwaitOpAsync("GetUsesOfSymbol", fun _ct -> + reactorOps.EnqueueAndAwaitOpAsync("GetUsesOfSymbol", fun ctok _ct -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + [| for r in tcSymbolUses do yield! r.GetUsesOfSymbol(symbol.Item) |] |> Seq.distinctBy (fun (itemOcc,_denv,m) -> itemOcc, m) |> Seq.filter (fun (itemOcc,_,_) -> itemOcc <> ItemOccurence.RelatedText) @@ -1920,7 +1932,9 @@ type FSharpCheckProjectResults(_keepAssemblyContents, errors: FSharpErrorInfo[], member info.GetAllUsesOfAllSymbols() = let (tcGlobals, tcImports, thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr) = getDetails() // This probably doesn't need to be run on the reactor since all data touched by GetAllUsesOfSymbols is immutable. - reactorOps.EnqueueAndAwaitOpAsync("GetAllUsesOfAllSymbols", fun _ct -> + reactorOps.EnqueueAndAwaitOpAsync("GetAllUsesOfAllSymbols", fun ctok _ct -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + [| for r in tcSymbolUses do for (item,itemOcc,denv,m) in r.GetAllUsesOfSymbols() do if itemOcc <> ItemOccurence.RelatedText then @@ -1969,7 +1983,9 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo | Some (_,_,reactor) -> // Make sure we run disposal in the reactor thread, since it may trigger type provider disposals etc. details <- None - reactor.EnqueueOp ("Dispose", fun () -> decrementer.Dispose()) + reactor.EnqueueOp ("Dispose", fun ctok -> + RequireCompilationThread ctok + decrementer.Dispose()) | _ -> () // Run an operation that needs to be run in the reactor thread @@ -1984,7 +2000,7 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo | Some (scope, builderOpt, reactor) -> // Ensure the builder doesn't get released while running operations asynchronously. use _unwind = match builderOpt with Some builder -> builder.IncrementUsageCount() | None -> { new System.IDisposable with member __.Dispose() = () } - let! res = reactor.EnqueueAndAwaitOpAsync(desc, fun _ct -> f scope) + let! res = reactor.EnqueueAndAwaitOpAsync(desc, fun ctok _ct -> f ctok scope) return res } @@ -2010,20 +2026,20 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo /// Intellisense autocompletions member info.GetDeclarationListInfo(parseResultsOpt, line, colAtEndOfNamesAndResidue, lineStr, qualifyingNames, partialName, ?hasTextChangedSinceLastTypecheck) = let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) - reactorOp "GetDeclarations" FSharpDeclarationListInfo.Empty (fun scope -> scope.GetDeclarations(parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck)) + reactorOp "GetDeclarations" FSharpDeclarationListInfo.Empty (fun ctok scope -> scope.GetDeclarations(ctok, parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck)) member info.GetDeclarationListSymbols(parseResultsOpt, line, colAtEndOfNamesAndResidue, lineStr, qualifyingNames, partialName, ?hasTextChangedSinceLastTypecheck) = let hasTextChangedSinceLastTypecheck = defaultArg hasTextChangedSinceLastTypecheck (fun _ -> false) - reactorOp "GetDeclarationListSymbols" List.empty (fun scope -> scope.GetDeclarationListSymbols(parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck)) + reactorOp "GetDeclarationListSymbols" List.empty (fun ctok scope -> scope.GetDeclarationListSymbols(ctok, parseResultsOpt, line, lineStr, colAtEndOfNamesAndResidue, qualifyingNames, partialName, hasTextChangedSinceLastTypecheck)) /// Resolve the names at the given location to give a data tip member info.GetStructuredToolTipTextAlternate(line, colAtEndOfNames, lineStr, names, tokenTag) = let dflt = FSharpToolTipText [] match tokenTagToTokenId tokenTag with | TOKEN_IDENT -> - reactorOp "GetToolTipText" dflt (fun scope -> scope.GetStructuredToolTipText line lineStr colAtEndOfNames names) + reactorOp "GetToolTipText" dflt (fun ctok scope -> scope.GetStructuredToolTipText(ctok, line, lineStr, colAtEndOfNames, names)) | TOKEN_STRING | TOKEN_STRING_TEXT -> - reactorOp "GetReferenceResolutionToolTipText" dflt (fun scope -> scope.GetReferenceResolutionStructuredToolTipText(line, colAtEndOfNames) ) + reactorOp "GetReferenceResolutionToolTipText" dflt (fun ctok scope -> scope.GetReferenceResolutionStructuredToolTipText(ctok, line, colAtEndOfNames) ) | _ -> async.Return dflt @@ -2032,34 +2048,34 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo |> Tooltips.Map Tooltips.ToFSharpToolTipText member info.GetF1KeywordAlternate (line, colAtEndOfNames, lineStr, names) = - reactorOp "GetF1Keyword" None (fun scope -> - scope.GetF1Keyword (line, lineStr, colAtEndOfNames, names)) + reactorOp "GetF1Keyword" None (fun ctok scope -> + scope.GetF1Keyword (ctok, line, lineStr, colAtEndOfNames, names)) // Resolve the names at the given location to a set of methods member info.GetMethodsAlternate(line, colAtEndOfNames, lineStr, names) = let dflt = FSharpMethodGroup("",[| |]) - reactorOp "GetMethods" dflt (fun scope-> - scope.GetMethods (line, lineStr, colAtEndOfNames, names)) + reactorOp "GetMethods" dflt (fun ctok scope -> + scope.GetMethods (ctok, line, lineStr, colAtEndOfNames, names)) member info.GetDeclarationLocationAlternate (line, colAtEndOfNames, lineStr, names, ?preferFlag) = let dflt = FSharpFindDeclResult.DeclNotFound FSharpFindDeclFailureReason.Unknown - reactorOp "GetDeclarationLocation" dflt (fun scope -> - scope.GetDeclarationLocation (line, lineStr, colAtEndOfNames, names, preferFlag)) + reactorOp "GetDeclarationLocation" dflt (fun ctok scope -> + scope.GetDeclarationLocation (ctok, line, lineStr, colAtEndOfNames, names, preferFlag)) member info.GetSymbolUseAtLocation (line, colAtEndOfNames, lineStr, names) = - reactorOp "GetSymbolUseAtLocation" None (fun scope -> - scope.GetSymbolUseAtLocation (line, lineStr, colAtEndOfNames, names) + reactorOp "GetSymbolUseAtLocation" None (fun ctok scope -> + scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) |> Option.map (fun (sym,denv,m) -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m))) member info.GetMethodsAsSymbols (line, colAtEndOfNames, lineStr, names) = - reactorOp "GetMethodsAsSymbols" None (fun scope -> - scope.GetMethodsAsSymbols (line, lineStr, colAtEndOfNames, names) + reactorOp "GetMethodsAsSymbols" None (fun ctok scope -> + scope.GetMethodsAsSymbols (ctok, line, lineStr, colAtEndOfNames, names) |> Option.map (fun (symbols,denv,m) -> symbols |> List.map (fun sym -> FSharpSymbolUse(scope.TcGlobals,denv,sym,ItemOccurence.Use,m)))) member info.GetSymbolAtLocationAlternate (line, colAtEndOfNames, lineStr, names) = - reactorOp "GetSymbolUseAtLocation" None (fun scope -> - scope.GetSymbolUseAtLocation (line, lineStr, colAtEndOfNames, names) + reactorOp "GetSymbolUseAtLocation" None (fun ctok scope -> + scope.GetSymbolUseAtLocation (ctok, line, lineStr, colAtEndOfNames, names) |> Option.map (fun (sym,_,_) -> sym)) member info.GetFormatSpecifierLocations() = @@ -2091,23 +2107,37 @@ type FSharpCheckFileResults(errors: FSharpErrorInfo[], scopeOptX: TypeCheckInfo FSharpProjectContext(scope.ThisCcu, scope.GetReferencedAssemblies(), scope.AccessRights)) member info.GetAllUsesOfAllSymbolsInFile() = - reactorOp "GetAllUsesOfAllSymbolsInFile" [| |] (fun scope -> + reactorOp "GetAllUsesOfAllSymbolsInFile" [| |] (fun ctok scope -> + + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + [| for (item,itemOcc,denv,m) in scope.ScopeSymbolUses.GetAllUsesOfSymbols() do if itemOcc <> ItemOccurence.RelatedText then let symbol = FSharpSymbol.Create(scope.TcGlobals, scope.ThisCcu, scope.TcImports, item) yield FSharpSymbolUse(scope.TcGlobals, denv, symbol, itemOcc, m) |]) member info.GetUsesOfSymbolInFile(symbol:FSharpSymbol) = - reactorOp "GetUsesOfSymbolInFile" [| |] (fun scope -> + reactorOp "GetUsesOfSymbolInFile" [| |] (fun ctok scope -> + + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + [| for (itemOcc,denv,m) in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun (itemOcc,_denv,m) -> itemOcc, m) do if itemOcc <> ItemOccurence.RelatedText then yield FSharpSymbolUse(scope.TcGlobals, denv, symbol, itemOcc, m) |]) member info.GetVisibleNamespacesAndModulesAtPoint(pos: pos) : Async = - reactorOp "GetVisibleNamespacesAndModulesAtPoint" [| |] (fun scope -> scope.GetVisibleNamespacesAndModulesAtPosition(pos) |> List.toArray) + reactorOp "GetVisibleNamespacesAndModulesAtPoint" [| |] (fun ctok scope -> + + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + + scope.GetVisibleNamespacesAndModulesAtPosition(pos) |> List.toArray) member info.IsRelativeNameResolvable(pos: pos, plid: string list, item: Item) : Async = - reactorOp "IsRelativeNameResolvable" true (fun scope -> scope.IsRelativeNameResolvable(pos, plid, item)) + reactorOp "IsRelativeNameResolvable" true (fun ctok scope -> + + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + + scope.IsRelativeNameResolvable(pos, plid, item)) //---------------------------------------------------------------------------- // BackgroundCompiler @@ -2161,6 +2191,8 @@ type FilePath = string type ProjectPath = string type FileVersion = int +type ParseCacheLockToken() = interface LockToken + // There is only one instance of this type, held in FSharpChecker type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions) as self = // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor @@ -2179,7 +2211,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.scriptClosureCache /// Information about the derived script closure. let scriptClosureCache = - MruCache(projectCacheSize, + MruCache(projectCacheSize, areSame=FSharpProjectOptions.AreSameForChecking, areSameForSubsumption=FSharpProjectOptions.AreSubsumable) @@ -2187,23 +2219,23 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent /// CreateOneIncrementalBuilder (for background type checking). Note that fsc.fs also /// creates an incremental builder used by the command line compiler. - let CreateOneIncrementalBuilder (options:FSharpProjectOptions, ct) = + let CreateOneIncrementalBuilder (ctok, options:FSharpProjectOptions, ct) = let projectReferences = [ for (nm,opts) in options.ReferencedProjects -> { new IProjectReference with member x.EvaluateRawContents() = - let r = self.ParseAndCheckProjectImpl(opts, ct) + let r = self.ParseAndCheckProjectImpl(opts, ctok, ct) r.RawFSharpAssemblyData member x.GetLogicalTimeStamp() = - self.GetLogicalTimeStampForProject(opts, ct) + self.GetLogicalTimeStampForProject(ctok, opts, ct) member x.FileName = nm } ] let builderOpt, diagnostics = IncrementalBuilder.TryCreateBackgroundBuilderForProjectOptions - (referenceResolver, frameworkTcImportsCache, scriptClosureCache.TryGet options, Array.toList options.ProjectFileNames, + (ctok, referenceResolver, frameworkTcImportsCache, scriptClosureCache.TryGet (ctok, options), Array.toList options.ProjectFileNames, Array.toList options.OtherOptions, projectReferences, options.ProjectDirectory, - options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions) + options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) // We're putting the builder in the cache, so increment its count. let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt @@ -2235,26 +2267,28 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent // /// Cache of builds keyed by options. let incrementalBuildersCache = - MruCache + MruCache (keepStrongly=projectCacheSize, keepMax=projectCacheSize, areSame = FSharpProjectOptions.AreSameForChecking, areSameForSubsumption = FSharpProjectOptions.AreSubsumable, requiredToKeep=(fun (builderOpt,_,_) -> match builderOpt with None -> false | Some b -> b.IsBeingKeptAliveApartFromCacheEntry), onDiscard = (fun (_, _, decrement) -> decrement.Dispose())) - let getOrCreateBuilder (options, ct) = - match incrementalBuildersCache.TryGet options with + let getOrCreateBuilder (ctok, options, ct) = + RequireCompilationThread ctok + match incrementalBuildersCache.TryGet (ctok, options) with | Some b -> b | None -> - let b = CreateOneIncrementalBuilder (options, ct) - incrementalBuildersCache.Set (options, b) + let b = CreateOneIncrementalBuilder (ctok, options, ct) + incrementalBuildersCache.Set (ctok, options, b) b + let parseCacheLock = Lock() // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.parseFileInProjectCache. Most recently used cache for parsing files. let parseFileInProjectCache = - MruCache<_, _>(parseFileInProjectCacheSize, + MruCache(parseFileInProjectCacheSize, areSame=AreSameForParsing3, areSameForSubsumption=AreSubsumable3) @@ -2267,28 +2301,25 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent /// - the source for the file may have changed let parseAndCheckFileInProjectCachePossiblyStale = - MruCache + MruCache (keepStrongly=incrementalTypeCheckCacheSize, areSame=AreSameForChecking2, areSameForSubsumption=AreSubsumable2) // Also keyed on source. This can only be out of date if the antecedent is out of date let parseAndCheckFileInProjectCache = - MruCache + MruCache (keepStrongly=incrementalTypeCheckCacheSize, areSame=AreSameForChecking3, areSameForSubsumption=AreSubsumable3) /// Holds keys for files being currently checked. It's used to prevent checking same file in parallel (interliveing chunck queued to Reactor). let beingCheckedFileTable = - System.Collections.Concurrent.ConcurrentDictionary + ConcurrentDictionary (HashIdentity.FromFunctions hash (fun (f1, o1, v1) (f2, o2, v2) -> f1 = f2 && v1 = v2 && FSharpProjectOptions.AreSameForChecking(o1, o2))) - let lockObj = obj() - let locked f = lock lockObj f - static let mutable foregroundParseCount = 0 static let mutable foregroundTypeCheckCount = 0 @@ -2317,11 +2348,13 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent | Some FSharpCheckFileAnswer.Aborted -> () | Some (FSharpCheckFileAnswer.Succeeded typedResults) -> foregroundTypeCheckCount <- foregroundTypeCheckCount + 1 - locked (fun () -> - parseAndCheckFileInProjectCachePossiblyStale.Set((filename,options),(parseResults,typedResults,fileVersion)) + parseCacheLock.AcquireLock (fun ltok -> + parseAndCheckFileInProjectCachePossiblyStale.Set(ltok, (filename,options),(parseResults,typedResults,fileVersion)) + + Console.WriteLine(sprintf "parseAndCheckFileInProjectCache SET key = %+A" (filename,source,options)) - parseAndCheckFileInProjectCache.Set((filename,source,options),(parseResults,typedResults,fileVersion,priorTimeStamp)) - parseFileInProjectCache.Set((filename,source,options),parseResults)) + parseAndCheckFileInProjectCache.Set(ltok, (filename,source,options),(parseResults,typedResults,fileVersion,priorTimeStamp)) + parseFileInProjectCache.Set(ltok, (filename,source,options),parseResults)) member bc.ImplicitlyStartCheckProjectInBackground(options) = if implicitlyStartBackgroundWork then @@ -2329,69 +2362,69 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent /// Parses the source file and returns untyped AST member bc.ParseFileInProject(filename:string, source,options:FSharpProjectOptions) = - match locked (fun () -> parseFileInProjectCache.TryGet (filename, source, options)) with + match parseCacheLock.AcquireLock (fun ctok -> parseFileInProjectCache.TryGet (ctok, (filename, source, options))) with | Some parseResults -> async.Return parseResults | None -> // Try this cache too (which might contain different entries) - let cachedResults = locked (fun () -> parseAndCheckFileInProjectCache.TryGet((filename,source,options))) + let cachedResults = parseCacheLock.AcquireLock (fun ctok -> parseAndCheckFileInProjectCache.TryGet(ctok,(filename,source,options))) match cachedResults with | Some (parseResults, _checkResults,_,_) -> async.Return parseResults | _ -> - reactor.EnqueueAndAwaitOpAsync("ParseFileInProject " + filename, fun ct -> + reactor.EnqueueAndAwaitOpAsync("ParseFileInProject " + filename, fun ctok ct -> // Try the caches again - it may have been filled by the time this operation runs - match locked (fun () -> parseFileInProjectCache.TryGet (filename, source, options)) with + match parseCacheLock.AcquireLock (fun ctok -> parseFileInProjectCache.TryGet (ctok, (filename, source, options))) with | Some parseResults -> parseResults | None -> - let cachedResults = locked (fun () -> parseAndCheckFileInProjectCache.TryGet((filename,source,options))) + let cachedResults = parseCacheLock.AcquireLock (fun ctok -> parseAndCheckFileInProjectCache.TryGet(ctok, (filename,source,options))) match cachedResults with | Some (parseResults, _checkResults,_,_) -> parseResults | _ -> foregroundParseCount <- foregroundParseCount + 1 - let builderOpt,creationErrors,_ = getOrCreateBuilder (options, ct) + let builderOpt,creationErrors,_ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> FSharpParseFileResults(List.toArray creationErrors, None, true, []) | Some builder -> // Do the parsing. let parseErrors, _matchPairs, inputOpt, anyErrors = - Parser.ParseOneFile (source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) + Parser.ParseOneFile (ctok, source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) let res = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.Dependencies ) - locked (fun () -> parseFileInProjectCache.Set ((filename, source, options), res)) + parseCacheLock.AcquireLock (fun ctok -> parseFileInProjectCache.Set (ctok, (filename, source, options), res)) res ) /// Fetch the parse information from the background compiler (which checks w.r.t. the FileSystem API) member bc.GetBackgroundParseResultsForFileInProject(filename, options) = - reactor.EnqueueAndAwaitOpAsync("GetBackgroundParseResultsForFileInProject " + filename, fun ct -> - let builderOpt, creationErrors, _ = getOrCreateBuilder (options, ct) + reactor.EnqueueAndAwaitOpAsync("GetBackgroundParseResultsForFileInProject " + filename, fun ctok ct -> + let builderOpt, creationErrors, _ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> FSharpParseFileResults(List.toArray creationErrors, None, true, []) | Some builder -> - let inputOpt,_,_,parseErrors = builder.GetParseResultsForFile (filename, ct) + let inputOpt,_,_,parseErrors = builder.GetParseResultsForFile (ctok, filename, ct) let dependencyFiles = builder.Dependencies let errors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, parseErrors) |] FSharpParseFileResults(errors = errors, input = inputOpt, parseHadErrors = false, dependencyFiles = dependencyFiles) ) member bc.MatchBraces(filename:string, source, options)= - reactor.EnqueueAndAwaitOpAsync("MatchBraces " + filename, fun ct -> - let builderOpt,_,_ = getOrCreateBuilder (options, ct) + reactor.EnqueueAndAwaitOpAsync("MatchBraces " + filename, fun ctok ct -> + let builderOpt,_,_ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> [| |] | Some builder -> let _parseErrors, matchPairs, _inputOpt, _anyErrors = - Parser.ParseOneFile (source, true, false, filename, builder.ProjectFileNames, builder.TcConfig) + Parser.ParseOneFile (ctok, source, true, false, filename, builder.ProjectFileNames, builder.TcConfig) matchPairs ) member bc.GetCachedCheckFileResult(builder: IncrementalBuilder,filename,source,options) = // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date - let cachedResults = locked (fun () -> parseAndCheckFileInProjectCache.TryGet((filename,source,options))) + let cachedResults = parseCacheLock.AcquireLock (fun ctok -> parseAndCheckFileInProjectCache.TryGet(ctok, (filename,source,options))) match cachedResults with // | Some (parseResults, checkResults, _, _) when builder.AreCheckResultsBeforeFileInProjectReady(filename) -> @@ -2438,7 +2471,9 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let! cachedResults = reactor.EnqueueAndAwaitOpAsync( "GetCachedCheckFileResult " + fileName, - (fun _ -> bc.GetCachedCheckFileResult(builder, fileName, source, options))) + (fun ctok _ -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + bc.GetCachedCheckFileResult(builder, fileName, source, options))) match cachedResults with | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults @@ -2447,7 +2482,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent try // Get additional script #load closure information if applicable. // For scripts, this will have been recorded by GetProjectOptionsFromScript. - let! loadClosure = reactor.EnqueueAndAwaitOpAsync("Try get from GetScriptClosureCache", (fun _ -> scriptClosureCache.TryGet options)) + let! loadClosure = reactor.EnqueueAndAwaitOpAsync("Try get from GetScriptClosureCache", (fun ctok _ -> scriptClosureCache.TryGet (ctok, options))) let! tcErrors, tcFileResult = Parser.TypeCheckOneFile(parseResults, source, fileName, options.ProjectFileName, tcPrior.TcConfig, tcPrior.TcGlobals, tcPrior.TcImports, tcPrior.TcState, loadClosure, tcPrior.Errors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo) @@ -2472,8 +2507,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync("CheckFileInProjectIfReady " + filename, action) async { try - let! cachedResults = execWithReactorAsync <| fun _ -> - match incrementalBuildersCache.TryGetAny options with + let! cachedResults = execWithReactorAsync <| fun ctok _ -> + match incrementalBuildersCache.TryGetAny (ctok, options) with | Some (Some builder, creationErrors, _) -> match bc.GetCachedCheckFileResult(builder, filename, source, options) with | Some (_, checkResults) -> Some (builder, creationErrors, Some (FSharpCheckFileAnswer.Succeeded checkResults)) @@ -2484,7 +2519,10 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent | None -> return None | Some (_, _, Some x) -> return Some x | Some (builder, creationErrors, None) -> - let! tcPrior = execWithReactorAsync <| fun _ -> builder.GetCheckResultsBeforeFileInProjectIfReady filename + let! tcPrior = + execWithReactorAsync <| fun ctok _ -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + builder.GetCheckResultsBeforeFileInProjectIfReady filename match tcPrior with | Some tcPrior -> let! checkResults = bc.CheckOneFile(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors) @@ -2499,17 +2537,21 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync("CheckFileInProject " + filename, action) async { let! ct = Async.CancellationToken - let builderOpt, creationErrors, _ = getOrCreateBuilder (options, ct) + let! builderOpt,creationErrors,_ = execWithReactorAsync <| fun ctok _ -> getOrCreateBuilder (ctok, options, ct) // Q: Whis it it ok to ignore creationErrors in the build cache? A: These errors will be appended into the typecheck results use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> return FSharpCheckFileAnswer.Succeeded (MakeCheckFileResultsEmpty(creationErrors)) | Some builder -> // Check the cache. We can only use cached results when there is no work to do to bring the background builder up-to-date - let! cachedResults = execWithReactorAsync <| fun _ -> bc.GetCachedCheckFileResult(builder, filename, source, options) + let! cachedResults = + execWithReactorAsync <| fun ctok _ -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + bc.GetCachedCheckFileResult(builder, filename, source, options) + match cachedResults with | Some (_, checkResults) -> return FSharpCheckFileAnswer.Succeeded checkResults | _ -> - let! tcPrior = execWithReactorAsync <| fun _ -> builder.GetCheckResultsBeforeFileInProject (filename, ct) + let! tcPrior = execWithReactorAsync <| fun ctok _ -> builder.GetCheckResultsBeforeFileInProject (ctok, filename, ct) let! checkAnswer = bc.CheckOneFile(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors) bc.ImplicitlyStartCheckProjectInBackground(options) return checkAnswer @@ -2520,24 +2562,30 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let execWithReactorAsync action = reactor.EnqueueAndAwaitOpAsync("ParseAndCheckFileInProject " + filename, action) async { let! ct = Async.CancellationToken - let! builderOpt,creationErrors,_ = execWithReactorAsync <| fun _ -> getOrCreateBuilder (options, ct) // Q: Whis it it ok to ignore creationErrors in the build cache? A: These errors will be appended into the typecheck results + let! builderOpt,creationErrors,_ = execWithReactorAsync <| fun ctok _ -> getOrCreateBuilder (ctok, options, ct) // Q: Whis it it ok to ignore creationErrors in the build cache? A: These errors will be appended into the typecheck results use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> let parseResults = FSharpParseFileResults(List.toArray creationErrors, None, true, []) return (parseResults, FSharpCheckFileAnswer.Aborted) + | Some builder -> - let! cachedResults = execWithReactorAsync <| fun _ -> bc.GetCachedCheckFileResult(builder, filename, source, options) + let! cachedResults = + execWithReactorAsync <| fun ctok _ -> + DoesNotRequireCompilerThreadTokenAndCouldPossiblyBeMadeConcurrent ctok + bc.GetCachedCheckFileResult(builder, filename, source, options) + match cachedResults with | Some (parseResults, checkResults) -> return parseResults, FSharpCheckFileAnswer.Succeeded checkResults | _ -> // todo this blocks the Reactor queue until all files up to the current are type checked. It's OK while editing the file, // but results with non cooperative blocking when a firts file from a project opened. - let! tcPrior = execWithReactorAsync <| fun _ -> builder.GetCheckResultsBeforeFileInProject (filename, ct) + let! tcPrior = execWithReactorAsync <| fun ctok _ -> builder.GetCheckResultsBeforeFileInProject (ctok, filename, ct) // Do the parsing. - let! parseErrors, _matchPairs, inputOpt, anyErrors = execWithReactorAsync <| fun _ -> - Parser.ParseOneFile (source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) + let! parseErrors, _matchPairs, inputOpt, anyErrors = + execWithReactorAsync <| fun ctok _ -> + Parser.ParseOneFile (ctok, source, false, true, filename, builder.ProjectFileNames, builder.TcConfig) let parseResults = FSharpParseFileResults(parseErrors, inputOpt, anyErrors, builder.Dependencies) let! checkResults = bc.CheckOneFile(parseResults, source, filename, options, textSnapshotInfo, fileVersion, builder, tcPrior, creationErrors) @@ -2547,8 +2595,8 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent /// Fetch the check information from the background compiler (which checks w.r.t. the FileSystem API) member bc.GetBackgroundCheckResultsForFileInProject(filename,options) = - reactor.EnqueueAndAwaitOpAsync("GetBackgroundCheckResultsForFileInProject " + filename, fun ct -> - let (builderOpt, creationErrors, _) = getOrCreateBuilder (options, ct) + reactor.EnqueueAndAwaitOpAsync("GetBackgroundCheckResultsForFileInProject " + filename, fun ctok ct -> + let (builderOpt, creationErrors, _) = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> @@ -2556,12 +2604,12 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let typedResults = MakeCheckFileResultsEmpty(creationErrors) (parseResults, typedResults) | Some builder -> - let (inputOpt, _, _, untypedErrors) = builder.GetParseResultsForFile (filename, ct) - let tcProj = builder.GetCheckResultsAfterFileInProject (filename, ct) + let (inputOpt, _, _, untypedErrors) = builder.GetParseResultsForFile (ctok, filename, ct) + let tcProj = builder.GetCheckResultsAfterFileInProject (ctok, filename, ct) let untypedErrors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, untypedErrors) |] let tcErrors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (builder.TcConfig, false, filename, tcProj.Errors) |] let parseResults = FSharpParseFileResults(errors = untypedErrors, input = inputOpt, parseHadErrors = false, dependencyFiles = builder.Dependencies) - let loadClosure = scriptClosureCache.TryGet options + let loadClosure = scriptClosureCache.TryGet (ctok, options) let scope = TypeCheckInfo(tcProj.TcConfig, tcProj.TcGlobals, tcProj.TcState.PartialAssemblySignature, tcProj.TcState.Ccu, tcProj.TcImports, tcProj.TcEnvAtEnd.AccessRights, options.ProjectFileName, filename, @@ -2578,45 +2626,45 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent member bc.TryGetRecentCheckResultsForFile(filename: string, options:FSharpProjectOptions, source) = match source with | Some sourceText -> - locked (fun () -> - match parseAndCheckFileInProjectCache.TryGet((filename,sourceText,options)) with + parseCacheLock.AcquireLock (fun ctok -> + match parseAndCheckFileInProjectCache.TryGet(ctok,(filename,sourceText,options)) with | Some (a,b,c,_) -> Some (a,b,c) | None -> None) - | None -> locked (fun () -> parseAndCheckFileInProjectCachePossiblyStale.TryGet((filename,options))) + | None -> parseCacheLock.AcquireLock (fun ctok -> parseAndCheckFileInProjectCachePossiblyStale.TryGet(ctok,(filename,options))) /// Parse and typecheck the whole project (the implementation, called recursively as project graph is evaluated) - member private bc.ParseAndCheckProjectImpl(options, ct) : FSharpCheckProjectResults = - let builderOpt,creationErrors,_ = getOrCreateBuilder (options, ct) + member private bc.ParseAndCheckProjectImpl(options, ctok, ct) : FSharpCheckProjectResults = + let builderOpt,creationErrors,_ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> FSharpCheckProjectResults (keepAssemblyContents, Array.ofList creationErrors, None, reactorOps) | Some builder -> - let (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ct) + let (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ctok, ct) let errors = [| yield! creationErrors; yield! Parser.CreateErrorInfos (tcProj.TcConfig, true, Microsoft.FSharp.Compiler.TcGlobals.DummyFileNameForRangesWithoutASpecificLocation, tcProj.Errors) |] FSharpCheckProjectResults (keepAssemblyContents, errors, Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.PartialAssemblySignature, tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt), reactorOps) /// Get the timestamp that would be on the output if fully built immediately - member private bc.GetLogicalTimeStampForProject(options, ct) = - let builderOpt,_creationErrors,_ = getOrCreateBuilder (options, ct) + member private bc.GetLogicalTimeStampForProject(ctok, options, ct) = + let builderOpt,_creationErrors,_ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> None - | Some builder -> Some (builder.GetLogicalTimeStampForProject()) + | Some builder -> Some (builder.GetLogicalTimeStampForProject(ctok)) /// Keep the projet builder alive over a scope member bc.KeepProjectAlive(options) = - reactor.EnqueueAndAwaitOpAsync("KeepProjectAlive " + options.ProjectFileName, fun ct -> - let builderOpt,_creationErrors,_ = getOrCreateBuilder (options, ct) + reactor.EnqueueAndAwaitOpAsync("KeepProjectAlive " + options.ProjectFileName, fun ctok ct -> + let builderOpt,_creationErrors,_ = getOrCreateBuilder (ctok, options, ct) // This increments, and lets the caller decrement IncrementalBuilder.KeepBuilderAlive builderOpt) /// Parse and typecheck the whole project. member bc.ParseAndCheckProject(options) = - reactor.EnqueueAndAwaitOpAsync("ParseAndCheckProject " + options.ProjectFileName, fun ct -> bc.ParseAndCheckProjectImpl(options, ct)) + reactor.EnqueueAndAwaitOpAsync("ParseAndCheckProject " + options.ProjectFileName, fun ctok ct -> bc.ParseAndCheckProjectImpl(options, ctok, ct)) member bc.GetProjectOptionsFromScript(filename, source, ?loadedTimeStamp, ?otherFlags, ?useFsiAuxLib, ?assumeDotNetFramework, ?extraProjectInfo: obj) = - reactor.EnqueueAndAwaitOpAsync ("GetProjectOptionsFromScript " + filename, fun _ct -> + reactor.EnqueueAndAwaitOpAsync ("GetProjectOptionsFromScript " + filename, fun ctok _ct -> // Do we add a reference to FSharp.Compiler.Interactive.Settings by default? let useFsiAuxLib = defaultArg useFsiAuxLib true // Do we assume .NET Framework references for scripts? @@ -2633,7 +2681,7 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent let collect _name = () let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB CompileOptions.ParseCompilerOptions (collect, fsiCompilerOptions, Array.toList otherFlags) - let loadClosure = LoadClosure.ComputeClosureOfSourceText(referenceResolver,filename, source, CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) + let loadClosure = LoadClosure.ComputeClosureOfSourceText(ctok, referenceResolver,filename, source, CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) let otherFlags = [| yield "--noframework"; yield "--warn:3"; yield! otherFlags @@ -2653,46 +2701,48 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent OriginalLoadReferences = loadClosure.OriginalLoadReferences ExtraProjectInfo=extraProjectInfo } - scriptClosureCache.Set(options,loadClosure) // Save the full load closure for later correlation. + scriptClosureCache.Set(ctok, options,loadClosure) // Save the full load closure for later correlation. options) member bc.InvalidateConfiguration(options : FSharpProjectOptions) = - reactor.EnqueueOp("InvalidateConfiguration", fun () -> + reactor.EnqueueOp("InvalidateConfiguration", fun ctok -> // This operation can't currently be cancelled and is not async let ct = CancellationToken.None - match incrementalBuildersCache.TryGetAny options with + match incrementalBuildersCache.TryGetAny (ctok, options) with | None -> () | Some (_oldBuilder, _, _) -> // We do not need to decrement here - the onDiscard function is called each time an entry is pushed out of the build cache, // including by SetAlternate. - let builderB, errorsB, decrementB = CreateOneIncrementalBuilder (options, ct) - incrementalBuildersCache.Set(options, (builderB, errorsB, decrementB)) + let builderB, errorsB, decrementB = CreateOneIncrementalBuilder (ctok, options, ct) + incrementalBuildersCache.Set(ctok, options, (builderB, errorsB, decrementB)) if implicitlyStartBackgroundWork then bc.CheckProjectInBackground(options)) - member bc.NotifyProjectCleaned(options : FSharpProjectOptions) = - match incrementalBuildersCache.TryGetAny options with - | None -> () - | Some (builderOpt, _, _) -> + member bc.NotifyProjectCleaned (options : FSharpProjectOptions) = + reactor.EnqueueAndAwaitOpAsync("NotifyProjectCleaned", fun ctok _ct -> + match incrementalBuildersCache.TryGetAny (ctok, options) with + | None -> () + | Some (builderOpt, _, _) -> #if EXTENSIONTYPING - builderOpt |> Option.iter (fun builder -> - if builder.ThereAreLiveTypeProviders then - bc.InvalidateConfiguration(options)) + builderOpt |> Option.iter (fun builder -> + if builder.ThereAreLiveTypeProviders then + bc.InvalidateConfiguration(options)) #else - () + () #endif + ) - member bc.CheckProjectInBackground(options) = - reactor.SetBackgroundOp(Some(fun () -> + member bc.CheckProjectInBackground (options) = + reactor.SetBackgroundOp (Some (fun ctok -> // The individual steps of the background build can't currently be cancelled let ct = CancellationToken.None - let builderOpt,_,_ = getOrCreateBuilder (options, ct) + let builderOpt,_,_ = getOrCreateBuilder (ctok, options, ct) use _unwind = IncrementalBuilder.KeepBuilderAlive builderOpt match builderOpt with | None -> false - | Some builder -> builder.Step(ct))) + | Some builder -> builder.Step(ctok, ct))) - member bc.StopBackgroundCompile() = + member bc.StopBackgroundCompile () = reactor.SetBackgroundOp(None) member bc.WaitForBackgroundCompile() = @@ -2709,25 +2759,25 @@ type BackgroundCompiler(referenceResolver, projectCacheSize, keepAssemblyContent member bc.CurrentQueueLength = reactor.CurrentQueueLength - member bc.ClearCachesAsync() = - reactor.EnqueueAndAwaitOpAsync ("ClearCachesAsync", fun _ct -> - locked (fun () -> - parseAndCheckFileInProjectCachePossiblyStale.Clear() - parseAndCheckFileInProjectCache.Clear() - parseFileInProjectCache.Clear()) - incrementalBuildersCache.Clear() - frameworkTcImportsCache.Clear() - scriptClosureCache.Clear()) + member bc.ClearCachesAsync () = + reactor.EnqueueAndAwaitOpAsync ("ClearCachesAsync", fun ctok _ct -> + parseCacheLock.AcquireLock (fun ltok -> + parseAndCheckFileInProjectCachePossiblyStale.Clear ltok + parseAndCheckFileInProjectCache.Clear ltok + parseFileInProjectCache.Clear ltok) + incrementalBuildersCache.Clear ctok + frameworkTcImportsCache.Clear ctok + scriptClosureCache.Clear ctok) member bc.DownsizeCaches() = - reactor.EnqueueAndAwaitOpAsync ("DownsizeCaches", fun _ct -> - locked (fun () -> - parseAndCheckFileInProjectCachePossiblyStale.Resize(keepStrongly=1) - parseAndCheckFileInProjectCache.Resize(keepStrongly=1) - parseFileInProjectCache.Resize(keepStrongly=1)) - incrementalBuildersCache.Resize(keepStrongly=1, keepMax=1) - frameworkTcImportsCache.Downsize() - scriptClosureCache.Resize(keepStrongly=1, keepMax=1)) + reactor.EnqueueAndAwaitOpAsync ("DownsizeCaches", fun ctok _ct -> + parseCacheLock.AcquireLock (fun ltok -> + parseAndCheckFileInProjectCachePossiblyStale.Resize(ltok, keepStrongly=1) + parseAndCheckFileInProjectCache.Resize(ltok, keepStrongly=1) + parseFileInProjectCache.Resize(ltok, keepStrongly=1)) + incrementalBuildersCache.Resize(ctok, keepStrongly=1, keepMax=1) + frameworkTcImportsCache.Downsize(ctok) + scriptClosureCache.Resize(ctok,keepStrongly=1, keepMax=1)) member __.FrameworkImportsCache = frameworkTcImportsCache member __.ImplicitlyStartBackgroundWork with get() = implicitlyStartBackgroundWork and set v = implicitlyStartBackgroundWork <- v @@ -2753,8 +2803,10 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.braceMatchCache. Most recently used cache for brace matching. Accessed on the // background UI thread, not on the compiler thread. + // + // This cache is safe for concurrent access because there is no onDiscard action for the items in the cache. let braceMatchCache = - MruCache<(string*string*FSharpProjectOptions),_>(braceMatchCacheSize, + MruCache(braceMatchCacheSize, areSame=AreSameForParsing3, areSameForSubsumption=AreSubsumable3) @@ -2768,11 +2820,11 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke member ic.MatchBracesAlternate(filename, source, options) = async { - match braceMatchCache.TryGet (filename, source, options) with + match braceMatchCache.TryGet (AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options)) with | Some res -> return res | None -> let! res = ComputeBraceMatching (filename, source, options) - braceMatchCache.Set ((filename, source, options), res) + braceMatchCache.Set (AssumeAnyCallerThreadWithoutEvidence(), (filename, source, options), res) return res } @@ -2795,7 +2847,8 @@ type FSharpChecker(referenceResolver, projectCacheSize, keepAssemblyContents, ke ic.ClearCaches() member ic.ClearCachesAsync() = - braceMatchCache.Clear() + let utok = AssumeAnyCallerThreadWithoutEvidence() + braceMatchCache.Clear(utok) backgroundCompiler.ClearCachesAsync() member ic.ClearCaches() = @@ -2925,12 +2978,12 @@ type FsiInteractiveChecker(reactorOps: IReactorOperations, tcConfig, tcGlobals, static member CreateErrorInfos (tcConfig, allErrors, mainInputFileName, errors) = Parser.CreateErrorInfos(tcConfig, allErrors, mainInputFileName, errors) - member __.ParseAndCheckInteraction (source) = + member __.ParseAndCheckInteraction (ctok, source) = async { let mainInputFileName = "stdin.fsx" // Note: projectSourceFiles is only used to compute isLastCompiland, and is ignored if Build.IsScript(mainInputFileName) is true (which it is in this case). let projectSourceFiles = [ ] - let parseErrors, _matchPairs, inputOpt, anyErrors = Parser.ParseOneFile (source, false, true, mainInputFileName, projectSourceFiles, tcConfig) + let parseErrors, _matchPairs, inputOpt, anyErrors = Parser.ParseOneFile (ctok, source, false, true, mainInputFileName, projectSourceFiles, tcConfig) let dependencyFiles = [] // interactions have no dependencies let parseResults = FSharpParseFileResults(parseErrors, inputOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) diff --git a/src/fsharp/vs/service.fsi b/src/fsharp/vs/service.fsi index e178a0a926..9aefd63acb 100755 --- a/src/fsharp/vs/service.fsi +++ b/src/fsharp/vs/service.fsi @@ -14,6 +14,7 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// Represents one parameter for one method (or other item) in a group. [] @@ -591,7 +592,7 @@ type internal FSharpChecker = member CurrentQueueLength : int /// This function is called when a project has been cleaned/rebuilt, and thus any live type providers should be refreshed. - member NotifyProjectCleaned: options: FSharpProjectOptions -> unit + member NotifyProjectCleaned: options: FSharpProjectOptions -> Async /// Notify the host that the logical type checking context for a file has now been updated internally /// and that the file has become eligible to be re-typechecked for errors. @@ -636,7 +637,7 @@ type internal FSharpChecker = // Used internally to provide intellisense over F# Interactive. type internal FsiInteractiveChecker = internal new : ops: IReactorOperations * tcConfig: TcConfig * tcGlobals: TcGlobals * tcImports: TcImports * tcState: TcState * loadClosure: LoadClosure option -> FsiInteractiveChecker - member internal ParseAndCheckInteraction : source:string -> Async + member internal ParseAndCheckInteraction : CompilationThreadToken * source:string -> Async static member internal CreateErrorInfos : tcConfig: TcConfig * allErrors:bool * mainInputFileName : string * seq -> FSharpErrorInfo[] /// Information about the compilation environment diff --git a/src/ilx/ilxsettings.fs b/src/ilx/ilxsettings.fs index bc4cccbe4c..8eb5133031 100644 --- a/src/ilx/ilxsettings.fs +++ b/src/ilx/ilxsettings.fs @@ -11,10 +11,10 @@ open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX type IlxCallImplementation = | VirtEntriesVirtCode -//++GLOBAL MUTABLE STATE +//++GLOBAL MUTABLE STATE (concurrency-safe because assigned only during F# library compilation) let ilxCompilingFSharpCoreLib = ref false -//++GLOBAL MUTABLE STATE +//++GLOBAL MUTABLE STATE (concurrency-safe because assigned only during F# library compilation) let ilxFsharpCoreLibAssemRef = ref (None : ILAssemblyRef option) /// Scope references for FSharp.Core.dll diff --git a/tests/scripts/compiler-perf-results.txt b/tests/scripts/compiler-perf-results.txt index 618d01462a..71c9410008 100644 --- a/tests/scripts/compiler-perf-results.txt +++ b/tests/scripts/compiler-perf-results.txt @@ -9,10 +9,8 @@ https://github.com/Microsoft/visualfsharp master 1ce06f8a8e https://github.com/Microsoft/visualfsharp master 536cfeb1cc3d74cd29ccd760715caac2cd2826e6 536cfeb1cc3d74cd29ccd760715caac2cd2826e6 202.52 11.59 31.16 48.09 61.13 51.83 https://github.com/Microsoft/visualfsharp master 983330c28ef5c06edbfd46b061c651f61fb851e1 983330c28ef5c06edbfd46b061c651f61fb851e1 197.77 11.27 32.00 45.83 63.09 52.52 https://github.com/Microsoft/visualfsharp master 4a275618b8976c5100c2054e07c3e153a70d00bf 4a275618b8976c5100c2054e07c3e153a70d00bf 201.81 11.58 30.85 46.67 56.16 46.84 -https://github.com/Microsoft/visualfsharp master 3bf3960d9790a6de73884b420cad4397ae066d77 3bf3960d9790a6de73884b420cad4397ae066d77 186.14 10.78 28.31 44.61 60.20 53.55 https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 195.60 11.52 30.96 46.07 62.75 52.24 -https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 194.06 12.02 38.93 57.16 61.63 50.16 -https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 193.89 11.25 30.64 45.71 62.94 52.00 +https://github.com/Microsoft/visualfsharp master 3bf3960d9790a6de73884b420cad4397ae066d77 3bf3960d9790a6de73884b420cad4397ae066d77 186.14 10.78 28.31 44.61 60.20 53.55 https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 195.60 11.52 30.96 46.07 62.75 52.24 https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 194.06 12.02 38.93 57.16 61.63 50.16 https://github.com/Microsoft/visualfsharp master c37ef6e30eae8d8eead61027166a0b723590048f c37ef6e30eae8d8eead61027166a0b723590048f 193.89 11.25 30.64 45.71 62.94 52.00 diff --git a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs index 7d3c3679ff..de6695a027 100644 --- a/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs +++ b/vsintegration/src/FSharp.LanguageService/XmlDocumentation.fs @@ -207,15 +207,18 @@ module internal XmlDocumentation = collector.Add Literals.space WriteNodes collector (p.Nodes()) + type VsThreadToken() = class end + let vsToken = VsThreadToken() + /// Provide Xml Documentation type Provider(xmlIndexService:IVsXMLMemberIndexService, dte: DTE) = /// Index of assembly name to xml member index. - let mutable xmlCache = new AgedLookup(10,areSame=(fun (x,y) -> x = y)) + let mutable xmlCache = new AgedLookup(10,areSame=(fun (x,y) -> x = y)) let events = dte.Events :?> Events2 let solutionEvents = events.SolutionEvents do solutionEvents.add_AfterClosing(fun () -> - xmlCache.Clear()) + xmlCache.Clear(vsToken)) #if DEBUG // Keep under DEBUG so that it can keep building. @@ -248,14 +251,14 @@ module internal XmlDocumentation = /// Retrieve the pre-existing xml index or None let GetMemberIndexOfAssembly(assemblyName) = - match xmlCache.TryGet(assemblyName) with + match xmlCache.TryGet(vsToken, assemblyName) with | Some(memberIndex) -> Some(memberIndex) | None -> let ok,memberIndex = xmlIndexService.CreateXMLMemberIndex(assemblyName) if Com.Succeeded(ok) then let ok = memberIndex.BuildMemberIndex() if Com.Succeeded(ok) then - xmlCache.Put(assemblyName,memberIndex) + xmlCache.Put(vsToken, assemblyName,memberIndex) Some(memberIndex) else None else None diff --git a/vsintegration/tests/Salsa/FSharpLanguageServiceTestable.fs b/vsintegration/tests/Salsa/FSharpLanguageServiceTestable.fs index 8a10e84ce8..652ab7bcd0 100644 --- a/vsintegration/tests/Salsa/FSharpLanguageServiceTestable.fs +++ b/vsintegration/tests/Salsa/FSharpLanguageServiceTestable.fs @@ -127,7 +127,7 @@ type internal FSharpLanguageServiceTestable() as this = /// Respond to project being cleaned/rebuilt (any live type providers in the project should be refreshed) member this.OnProjectCleaned(projectSite:IProjectSite) = let checkOptions = ProjectSitesAndFiles.GetProjectOptionsForProjectSite(projectSite, "" ,None, serviceProvider.Value) - this.FSharpChecker.NotifyProjectCleaned(checkOptions) + this.FSharpChecker.NotifyProjectCleaned(checkOptions) |> Async.RunSynchronously member this.OnActiveViewChanged(textView) = bgRequests.OnActiveViewChanged(textView) diff --git a/vsintegration/tests/unittests/Tests.InternalCollections.fs b/vsintegration/tests/unittests/Tests.InternalCollections.fs index 0fac842dd6..0aca1861a8 100644 --- a/vsintegration/tests/unittests/Tests.InternalCollections.fs +++ b/vsintegration/tests/unittests/Tests.InternalCollections.fs @@ -112,6 +112,8 @@ type MruCache = printfn "discarded = %A" discarded.Value Assert.IsTrue(discarded.Value = ["y";"x";"Apple";"Banana"], "Check6") #endif + +type AccessToken() = class end [] type AgedLookup() = @@ -119,21 +121,22 @@ type AgedLookup() = let mutable hold198 : byte [] = null let mutable hold199 : byte [] = null + let atok = AccessToken() let WeakRefTest n = - let al = AgedLookup(n, (fun (x,y) -> x = y)) + let al = AgedLookup(n, (fun (x,y) -> x = y)) let AssertCached(i,o:byte array) = - match al.TryPeekKeyValue(i) with + match al.TryPeekKeyValue(atok,i) with | Some(_,x) -> Assert.IsTrue(obj.ReferenceEquals(o,x), sprintf "Object in cache (%d) does not agree with expectation (%d)" x.[0] i) | None -> Assert.IsTrue(false, "Object fell out of cache") let AssertExistsInCached(i) = - match al.TryPeekKeyValue(i) with + match al.TryPeekKeyValue(atok,i) with | Some _ -> () | None -> Assert.IsTrue(false, "Object fell out of cache") let AssertNotCached(i) = - match al.TryPeekKeyValue(i) with + match al.TryPeekKeyValue(atok,i) with | Some _ -> Assert.IsTrue(false, "Expected key to have fallen out of cache") | None -> () @@ -145,7 +148,7 @@ type AgedLookup() = if i = 197 then hold197<-large if i = 198 then hold198<-large if i = 199 then hold199<-large - al.Put(i, large) + al.Put(atok, i, large) large<-null finally printfn "ensure these objects are never on the stack of the top-level test" @@ -208,7 +211,7 @@ type AgedLookup() = f() // Let go of everything else. - al.Clear() + al.Clear(atok) GC.Collect() diff --git a/vsintegration/tests/unittests/Tests.LanguageService.IncrementalBuild.fs b/vsintegration/tests/unittests/Tests.LanguageService.IncrementalBuild.fs index fb470bca9f..e1951bd369 100644 --- a/vsintegration/tests/unittests/Tests.LanguageService.IncrementalBuild.fs +++ b/vsintegration/tests/unittests/Tests.LanguageService.IncrementalBuild.fs @@ -22,16 +22,19 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library module internal Vector = /// Convert from vector to a scalar let ToScalar<'I> (taskname:string) (input:Vector<'I>) : Scalar<'I array> = - let Identity inArray = inArray + let Identity _ inArray = inArray Vector.Demultiplex taskname Identity input - +[] +module internal Values = + let ctok = AssumeCompilationThreadWithoutEvidence() + [] [] [] type IncrementalBuild() = - let save _ = () + let save _ctok _ = () let ct = CancellationToken.None /// Called per test @@ -56,14 +59,14 @@ type IncrementalBuild() = let updateStamp = ref true - let StampFile filename = + let StampFile _ctok filename = let result = File.GetLastWriteTime(filename) if !updateStamp then // Here, simulate that VS is writing to our file. TouchFile() result - let Map filename = + let Map _ctok filename = "map:"+filename let buildDesc = new BuildDescriptionScope() @@ -75,7 +78,7 @@ type IncrementalBuild() = let bound = buildDesc.GetInitialPartialBuild inputs let DoCertainStep bound = - match IncrementalBuild.Step save ct (Target(mapped,None)) bound with + match IncrementalBuild.Step ctok save ct (Target(mapped,None)) bound with | Some bound -> bound | None -> failwith "Expected to be able to step" @@ -91,7 +94,7 @@ type IncrementalBuild() = updateStamp:=false bound <- DoCertainStep bound bound <- DoCertainStep bound - match IncrementalBuild.Step save ct (Target (mapped, None)) bound with + match IncrementalBuild.Step ctok save ct (Target (mapped, None)) bound with | Some bound -> failwith "Build should have stopped" | None -> () @@ -101,11 +104,11 @@ type IncrementalBuild() = member public rb.StampScan() = let mapSuffix = ref "Suffix1" - let Scan acc filename = + let Scan ctok acc filename = eventually { return acc+"-"+filename+"-"+(!mapSuffix) } let stampAs = ref DateTime.Now - let StampFile(filename) = + let StampFile _ctok filename = !stampAs let buildDesc = new BuildDescriptionScope() @@ -121,14 +124,14 @@ type IncrementalBuild() = printf "-[Step1]----------------------------------------------------------------------------------------\n" // Evaluate the first time. - let bound = Eval save ct scanned bound + let bound = Eval ctok save ct scanned bound let r = GetVectorResult (scanned, bound) Assert.AreEqual("AccVal-File1.fs-Suffix1-File2.fs-Suffix1",r.[1]) printf "-[Step2]----------------------------------------------------------------------------------------\n" // Evaluate the second time. No change should be seen. mapSuffix:="Suffix2" - let bound = Eval save ct scanned bound + let bound = Eval ctok save ct scanned bound let r = GetVectorResult (scanned,bound) Assert.AreEqual("AccVal-File1.fs-Suffix1-File2.fs-Suffix1",r.[1]) @@ -136,7 +139,7 @@ type IncrementalBuild() = // Evaluate a third time with timestamps updated. Should cause a rebuild System.Threading.Thread.Sleep 10 // Sleep a little to avoid grabbing the same 'Now' stampAs:=DateTime.Now - let bound = Eval save ct scanned bound + let bound = Eval ctok save ct scanned bound let r = GetVectorResult (scanned,bound) Assert.AreEqual("AccVal-File1.fs-Suffix2-File2.fs-Suffix2",r.[1]) @@ -145,9 +148,9 @@ type IncrementalBuild() = [] member public rb.aaZeroElementVector() = // Starts with 'aa' to put it at the front. let stamp = ref DateTime.Now - let Stamp(s:string) = !stamp - let Map(s:string) = s - let Demult(a:string array) : int = a.Length + let Stamp ctok (s:string) = !stamp + let Map ctok (s:string) = s + let Demult ctok (a:string array) : int = a.Length let buildDesc = new BuildDescriptionScope() let inputVector = InputVector "InputVector" @@ -162,7 +165,7 @@ type IncrementalBuild() = let inputs1 = [ BuildInput.VectorInput(inputVector, [""]) ] let build1 = buildDesc.GetInitialPartialBuild inputs1 - let build1Evaled = Eval save ct result build1 + let build1Evaled = Eval ctok save ct result build1 let r1 = GetScalarResult (result, build1Evaled) match r1 with | Some(v,dt) -> Assert.AreEqual(1,v) @@ -173,7 +176,7 @@ type IncrementalBuild() = let inputs0 = [ BuildInput.VectorInput(inputVector, []) ] let build0 = buildDesc.GetInitialPartialBuild inputs0 - let build0Evaled = Eval save ct result build0 + let build0Evaled = Eval ctok save ct result build0 let r0 = GetScalarResult (result, build0Evaled) match r0 with | Some(v,dt) -> Assert.AreEqual(0,v) @@ -187,11 +190,11 @@ type IncrementalBuild() = let elements = ref 1 let timestamp = ref System.DateTime.Now let Input() : string array = [| for i in 1..!elements -> sprintf "Element %d" i |] - let Stamp(s) = !timestamp - let Map(s:string) = sprintf "Mapped %s " s - let Result(a:string[]) : string = String.Join(",", a) + let Stamp ctok s = !timestamp + let Map ctok (s:string) = sprintf "Mapped %s " s + let Result ctok (a:string[]) : string = String.Join(",", a) let now = System.DateTime.Now - let FixedTimestamp _ = now + let FixedTimestamp _ctok _ = now let buildDesc = new BuildDescriptionScope() let input = InputVector "InputVector" @@ -209,7 +212,7 @@ type IncrementalBuild() = // Evaluate it with value 1 elements := 1 - let bound = Eval save ct result bound + let bound = Eval ctok save ct result bound let r1 = GetScalarResult(result, bound) match r1 with | Some(s,dt) -> printfn "%s" s @@ -220,7 +223,7 @@ type IncrementalBuild() = System.Threading.Thread.Sleep(100) timestamp := System.DateTime.Now - let bound = Eval save ct result bound + let bound = Eval ctok save ct result bound let r2 = GetScalarResult (result, bound) match r2 with | Some(s,dt) -> Assert.AreEqual("Mapped Input 0 ",s) @@ -309,11 +312,11 @@ type IncrementalBuild() = member public rb.StampMap() = let mapSuffix = ref "Suffix1" - let MapIt(filename) = + let MapIt ctok filename = filename+"."+(!mapSuffix) let stampAs = ref DateTime.Now - let StampFile(filename) = + let StampFile ctok filename = !stampAs let buildDesc = new BuildDescriptionScope() @@ -326,14 +329,14 @@ type IncrementalBuild() = printf "-[Step1]----------------------------------------------------------------------------------------\n" // Evaluate the first time. - let bound = Eval save ct mapped bound + let bound = Eval ctok save ct mapped bound let r = GetVectorResult (mapped,bound) Assert.AreEqual("File2.fs.Suffix1",r.[1]) printf "-[Step2]----------------------------------------------------------------------------------------\n" // Evaluate the second time. No change should be seen. mapSuffix:="Suffix2" - let bound = Eval save ct mapped bound + let bound = Eval ctok save ct mapped bound let r = GetVectorResult (mapped,bound) Assert.AreEqual("File2.fs.Suffix1",r.[1]) @@ -342,7 +345,7 @@ type IncrementalBuild() = while !stampAs = DateTime.Now do System.Threading.Thread.Sleep 10 // Sleep a little to avoid grabbing the same 'Now' stampAs:=DateTime.Now - let bound = Eval save ct mapped bound + let bound = Eval ctok save ct mapped bound let r = GetVectorResult (mapped,bound) Assert.AreEqual("File2.fs.Suffix2",r.[1]) @@ -351,11 +354,11 @@ type IncrementalBuild() = member public rb.StampDemultiplex() = let joinedResult = ref "Join1" - let Join(filenames:_[]) = + let Join ctok (filenames:_[]) = !joinedResult let stampAs = ref DateTime.Now - let StampFile(filename) = + let StampFile ctok filename = !stampAs let buildDesc = new BuildDescriptionScope() @@ -368,14 +371,14 @@ type IncrementalBuild() = printf "-[Step1]----------------------------------------------------------------------------------------\n" // Evaluate the first time. - let bound = Eval save ct joined bound + let bound = Eval ctok save ct joined bound let (r,_) = Option.get (GetScalarResult(joined,bound)) Assert.AreEqual("Join1",r) printf "-[Step2]----------------------------------------------------------------------------------------\n" // Evaluate the second time. No change should be seen. joinedResult:="Join2" - let bound = Eval save ct joined bound + let bound = Eval ctok save ct joined bound let (r,_) = Option.get (GetScalarResult (joined,bound)) Assert.AreEqual("Join1",r) @@ -384,7 +387,7 @@ type IncrementalBuild() = while !stampAs = DateTime.Now do System.Threading.Thread.Sleep 10 // Sleep a little to avoid grabbing the same 'Now' stampAs:=DateTime.Now - let bound = Eval save ct joined bound + let bound = Eval ctok save ct joined bound let (r,_) = Option.get (GetScalarResult (joined,bound)) Assert.AreEqual("Join2",r) @@ -392,8 +395,8 @@ type IncrementalBuild() = /// Test that Demultiplex followed by ScanLeft works [] member public rb.DemultiplexScanLeft() = - let Size(ar:_[]) = ar.Length - let Scan acc (file :string) = eventually { return acc + file.Length } + let Size ctok (ar:_[]) = ar.Length + let Scan ctok acc (file :string) = eventually { return acc + file.Length } let buildDesc = new BuildDescriptionScope() let inVector = InputVector "InputVector" let vectorSize = Vector.Demultiplex "Demultiplex" Size inVector @@ -403,7 +406,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.VectorInput(inVector, ["File1.fs";"File2.fs";"File3.fs"]) ] let bound = buildDesc.GetInitialPartialBuild inputs - let e = Eval save ct scanned bound + let e = Eval ctok save ct scanned bound let r = GetScalarResult (vectorSize,e) match r with | Some(r,_) -> Assert.AreEqual(3,r) @@ -457,7 +460,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.ScalarInput(inScalar, "A Scalar Value") ] let bound = buildDesc.GetInitialPartialBuild inputs - let e = Eval save ct inScalar bound + let e = Eval ctok save ct inScalar bound let r = GetScalarResult(inScalar,e) match r with | Some(r,_) -> Assert.AreEqual("A Scalar Value", r) @@ -466,7 +469,7 @@ type IncrementalBuild() = /// Test that ScanLeft works. [] member public rb.ScanLeft() = - let DoIt (a:int*string) (b:string) = + let DoIt ctok (a:int*string) (b:string) = eventually { return ((fst a)+1,b) } let buildDesc = new BuildDescriptionScope() @@ -480,7 +483,7 @@ type IncrementalBuild() = BuildInput.ScalarInput(inScalar, (5,"")) ] let bound = buildDesc.GetInitialPartialBuild(inputs) - let e = Eval save ct result bound + let e = Eval ctok save ct result bound let r = GetVectorResult(result,e) if [| (6,"File1.fs"); (7,"File2.fs"); (8, "File3.fs") |] <> r then printfn "Got %A" r @@ -497,7 +500,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.VectorInput(inVector, ["File1.fs";"File2.fs";"File3.fs"]) ] let bound = buildDesc.GetInitialPartialBuild(inputs) - let e = Eval save ct result bound + let e = Eval ctok save ct result bound let r = GetScalarResult (result, e) match r with | Some(r,ts)-> @@ -520,7 +523,7 @@ type IncrementalBuild() = let cts = new CancellationTokenSource() cts.Cancel() - let res = try Eval save cts.Token result bound |> ignore; false with :? OperationCanceledException -> true + let res = try Eval ctok save cts.Token result bound |> ignore; false with :? OperationCanceledException -> true Assert.AreEqual(res, true) @@ -528,16 +531,16 @@ type IncrementalBuild() = /// that were new at the time: Scalars, Invalidation, Disposal [] member public rb.AssemblyReferenceModel() = - let ParseTask(filename) = sprintf "Parse(%s)" filename + let ParseTask ctok filename = sprintf "Parse(%s)" filename let now = System.DateTime.Now - let StampFileNameTask filename = now - let TimestampReferencedAssemblyTask reference = now - let ApplyMetaCommands(parseResults:string[]) = "tcConfig-of("+String.Join(",",parseResults)+")" - let GetReferencedAssemblyNames(tcConfig) = [|"Assembly1.dll";"Assembly2.dll";"Assembly3.dll"|] - let ReadAssembly(assemblyName) = sprintf "tcImport-of(%s)" assemblyName - let CombineImportedAssembliesTask(imports) = "tcAcc" - let TypeCheckTask tcAcc parseResults = eventually { return tcAcc } - let FinalizeTypeCheckTask results = "finalized" + let StampFileNameTask ctok filename = now + let TimestampReferencedAssemblyTask ctok reference = now + let ApplyMetaCommands ctok (parseResults:string[]) = "tcConfig-of("+String.Join(",",parseResults)+")" + let GetReferencedAssemblyNames ctok (tcConfig) = [|"Assembly1.dll";"Assembly2.dll";"Assembly3.dll"|] + let ReadAssembly ctok assemblyName = sprintf "tcImport-of(%s)" assemblyName + let CombineImportedAssembliesTask ctok imports = "tcAcc" + let TypeCheckTask ctok tcAcc parseResults = eventually { return tcAcc } + let FinalizeTypeCheckTask ctok results = "finalized" // Build rules. let buildDesc = new BuildDescriptionScope() @@ -569,14 +572,14 @@ type IncrementalBuild() = [ BuildInput.VectorInput(fileNamesNode, ["File1.fs";"File2.fs";"File3.fs"]); BuildInput.VectorInput(referencedAssembliesNode, [("lib1.dll", now);("lib2.dll", now)]) ] let bound = buildDesc.GetInitialPartialBuild(inputs) - let e = Eval save ct finalizedTypeCheckNode bound + let e = Eval ctok save ct finalizedTypeCheckNode bound let r = GetScalarResult(finalizedTypeCheckNode,e) () [] member public rb.OneToOneWorks() = - let VectorModify (input:int) : string = + let VectorModify ctok (input:int) : string = sprintf "Transformation of %d" input let buildDesc = new BuildDescriptionScope() @@ -586,7 +589,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.VectorInput(inputs, [1;2;3;4]) ] let bound = buildDesc.GetInitialPartialBuild inputs - let evaled = Eval save ct outputs bound + let evaled = Eval ctok save ct outputs bound let outputs = GetVectorResult(outputs,evaled) Assert.AreEqual("Transformation of 4", outputs.[3]) () @@ -595,7 +598,7 @@ type IncrementalBuild() = /// The getExprById function couldn't find it. [] member public rb.HiddenOutputGroup() = - let VectorModify (input:int) : string = + let VectorModify ctok (input:int) : string = sprintf "Transformation of %d" input let buildDesc = new BuildDescriptionScope() @@ -611,7 +614,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.VectorInput(inputs, [1;2;3;4]) ] let bound = buildDesc.GetInitialPartialBuild inputs - let evaled = Eval save ct outputs bound + let evaled = Eval ctok save ct outputs bound let outputs = GetVectorResult(outputs,evaled) Assert.AreEqual("Transformation of 4", outputs.[3]) () @@ -619,7 +622,7 @@ type IncrementalBuild() = /// Empty build should just be a NOP. [] member public rb.EmptyBuildIsNop() = - let VectorModify (input:int) : string = + let VectorModify ctok (input:int) : string = sprintf "Transformation of %d" input let buildDesc = new BuildDescriptionScope() @@ -629,7 +632,7 @@ type IncrementalBuild() = let inputs = [ BuildInput.VectorInput(inputs, []) ] let bound = buildDesc.GetInitialPartialBuild inputs - let evaled = Eval save ct outputs bound + let evaled = Eval ctok save ct outputs bound let outputs = GetVectorResult(outputs,evaled) ()