Make concurrency assumptions more explicit via token passing (#2371)

* tame concurrency draft

* tame-conc

* fix tests

* fix build

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

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<string,string list>()
 
-//  ++GLOBAL MUTABLE STATE
+//  ++GLOBAL MUTABLE STATE (concurrency-safe)
 let memoizeNamespaceRightTable = new ConcurrentDictionary<string,string option * string>()
 
 
@@ -92,7 +92,7 @@ let splitNamespace nm =
 
 let splitNamespaceMemoized nm = splitNamespace nm
 
-// ++GLOBAL MUTABLE STATE
+// ++GLOBAL MUTABLE STATE (concurrency-safe)
 let memoizeNamespaceArrayTable = 
     Concurrent.ConcurrentDictionary<string,string[]>()
 
@@ -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 

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<CompilationThreadToken>
+
+/// 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<AnyCallerThreadToken>
+
+/// 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>)
 
 [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
 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<Eventually<'T>>) (e: Eventually<'T>) : Async<'T option> =
+    let forceAsync (runner: (CompilationThreadToken -> Eventually<'T>) -> Async<Eventually<'T>>) (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

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<ILModuleReaderCacheLockToken, (string * System.DateTime), ILModuleReader>(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 = 

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
 
 

src/absil/ilreflect.fs

@@ -336,7 +336,7 @@ type cenv =
     { ilg: ILGlobals
       tryFindSysILTypeRef : string -> ILTypeRef option
       generatePdb: bool
-      resolvePath: (ILAssemblyRef -> Choice<string,System.Reflection.Assembly> option) }
+      resolveAssemblyRef: (ILAssemblyRef -> Choice<string,System.Reflection.Assembly> 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