Merge pull request #10310 from TIHan/type-provider-forced-compilation-thread

Sequentialise type provider calls by using a lock rather than requiring the Reactor single threading

Author: dsyme

src/fsharp/CompilerConfig.fs

@@ -238,14 +238,6 @@ type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * Assem
 type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted<ITypeProvider> list
 #endif
 
-/// The thread in which compilation calls will be enqueued and done work on.
-/// Note: This is currently only used when disposing of type providers and will be extended to all the other type provider calls when compilations can be done in parallel.
-///       Right now all calls in FCS to type providers are single-threaded through use of the reactor thread. 
-type ICompilationThread =
-
-    /// Enqueue work to be done on a compilation thread.
-    abstract EnqueueWork: (CompilationThreadToken -> unit) -> unit
-
 type ImportedAssembly =
     { ILScopeRef: ILScopeRef 
       FSharpViewOfMetadata: CcuThunk
@@ -442,7 +434,6 @@ type TcConfigBuilder =
       /// show messages about extension type resolution?
       mutable showExtensionTypeMessages: bool
 #endif
-      mutable compilationThread: ICompilationThread
 
       /// pause between passes? 
       mutable pause: bool
@@ -603,9 +594,6 @@ type TcConfigBuilder =
 #if !NO_EXTENSIONTYPING
           showExtensionTypeMessages = false
 #endif
-          compilationThread = 
-                let ctok = CompilationThreadToken ()
-                { new ICompilationThread with member __.EnqueueWork work = work ctok }
           pause = false 
           alwaysCallVirt = true
           noDebugData = false
@@ -1000,7 +988,6 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) =
 #if !NO_EXTENSIONTYPING
     member x.showExtensionTypeMessages = data.showExtensionTypeMessages
 #endif
-    member x.compilationThread = data.compilationThread
     member x.pause = data.pause
     member x.alwaysCallVirt = data.alwaysCallVirt
     member x.noDebugData = data.noDebugData

src/fsharp/CompilerConfig.fsi

@@ -92,14 +92,6 @@ type AssemblyReference =
 
 type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * AssemblyReference list
 
-/// The thread in which compilation calls will be enqueued and done work on.
-/// Note: This is currently only used when disposing of type providers and will be extended to all the other type provider calls when compilations can be done in parallel.
-///       Right now all calls in FCS to type providers are single-threaded through use of the reactor thread. 
-type ICompilationThread =
-
-    /// Enqueue work to be done on a compilation thread.
-    abstract EnqueueWork: (CompilationThreadToken -> unit) -> unit
-
 [<RequireQualifiedAccess>]
 type CompilerTarget = 
     | WinExe 
@@ -251,7 +243,6 @@ type TcConfigBuilder =
 #if !NO_EXTENSIONTYPING
       mutable showExtensionTypeMessages: bool
 #endif
-      mutable compilationThread: ICompilationThread
       mutable pause: bool 
       mutable alwaysCallVirt: bool
       mutable noDebugData: bool
@@ -429,7 +420,6 @@ type TcConfig =
 #if !NO_EXTENSIONTYPING
     member showExtensionTypeMessages: bool
 #endif
-    member compilationThread: ICompilationThread
     member pause: bool 
     member alwaysCallVirt: bool
     member noDebugData: bool

src/fsharp/CompilerImports.fs

@@ -695,9 +695,9 @@ type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyR
 type TcImportsSafeDisposal
     (disposeActions: ResizeArray<unit -> unit>,
 #if !NO_EXTENSIONTYPING
-     disposeTypeProviderActions: ResizeArray<unit -> unit>,
+     disposeTypeProviderActions: ResizeArray<unit -> unit>
 #endif
-     compilationThread: ICompilationThread) =
+    ) =
 
     let mutable isDisposed = false
 
@@ -707,9 +707,7 @@ type TcImportsSafeDisposal
         if verbose then 
             dprintf "disposing of TcImports, %d binaries\n" disposeActions.Count
 #if !NO_EXTENSIONTYPING
-        let actions = disposeTypeProviderActions
-        if actions.Count > 0 then
-            compilationThread.EnqueueWork (fun _ -> for action in actions do action())
+        for action in disposeTypeProviderActions do action()
 #endif
         for action in disposeActions do action()
 
@@ -760,8 +758,7 @@ and TcImportsWeakHack (tcImports: WeakReference<TcImports>) =
 /// Is a disposable object, but it is recommended not to explicitly call Dispose unless you absolutely know nothing will be using its contents after the disposal.
 /// Otherwise, simply allow the GC to collect this and it will properly call Dispose from the finalizer.
 and [<Sealed>] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAssemblyResolutions, importsBase: TcImports option,
-                         ilGlobalsOpt, compilationThread: ICompilationThread, 
-                         dependencyProviderOpt: DependencyProvider option) as this = 
+                         ilGlobalsOpt, dependencyProviderOpt: DependencyProvider option) as this = 
 
     let mutable resolutions = initialResolutions
     let mutable importsBase: TcImports option = importsBase
@@ -786,7 +783,7 @@ and [<Sealed>] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse
     let mutable tcImportsWeak = TcImportsWeakHack (WeakReference<_> this)
 #endif
 
-    let disposal = new TcImportsSafeDisposal(disposeActions, disposeTypeProviderActions, compilationThread)
+    let disposal = new TcImportsSafeDisposal(disposeActions, disposeTypeProviderActions)
 
     let CheckDisposed() =
         if disposed then assert false
@@ -1257,7 +1254,7 @@ and [<Sealed>] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse
             for provider in providers do 
                 tcImportsStrong.AttachDisposeTypeProviderAction(fun () -> 
                     try 
-                        provider.PUntaintNoFailure(fun x -> x).Dispose() 
+                        provider.PUntaintNoFailure(fun x -> x.Dispose())
                     with e -> 
                         ())
 
@@ -1667,7 +1664,7 @@ and [<Sealed>] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse
         let tcResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(ctok, tcConfig, frameworkDLLs, [])
         let tcAltResolutions = TcAssemblyResolutions.BuildFromPriorResolutions(ctok, tcConfig, nonFrameworkDLLs, [])
 
-        let frameworkTcImports = new TcImports(tcConfigP, tcResolutions, None, None, tcConfig.compilationThread, None) 
+        let frameworkTcImports = new TcImports(tcConfigP, tcResolutions, None, None, None) 
 
         // Fetch the primaryAssembly from the referenced assemblies otherwise 
         let primaryAssemblyReference =
@@ -1801,7 +1798,7 @@ and [<Sealed>] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse
         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, tcConfig.compilationThread, Some dependencyProvider)
+        let tcImports = new TcImports(tcConfigP, tcResolutions, Some baseTcImports, Some tcGlobals.ilg, Some dependencyProvider)
         let! _assemblies = tcImports.RegisterAndImportReferencedAssemblies(ctok, references)
         tcImports.ReportUnresolvedAssemblyReferences knownUnresolved
         return tcImports

src/fsharp/ExtensionTyping.fs

@@ -171,7 +171,7 @@ module internal ExtensionTyping =
                     tpe.Iter(fun e -> errorR(NumberedError((e.Number, e.ContextualErrorMessage), m)) )
                     []
 
-        let providers = Tainted<_>.CreateAll providerSpecs
+        let providers = Tainted<_>.CreateAll(providerSpecs)
 
         providers
 

src/fsharp/service/IncrementalBuild.fs

@@ -2086,14 +2086,6 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput
                 // Never open PDB files for the language service, even if --standalone is specified
                 tcConfigB.openDebugInformationForLaterStaticLinking <- false
 
-                tcConfigB.compilationThread <- 
-                    { new ICompilationThread with 
-                        member __.EnqueueWork work = 
-                            Reactor.Singleton.EnqueueOp ("Unknown", "ICompilationThread.EnqueueWork", "work", fun ctok ->
-                                work ctok
-                            )
-                    }
-
                 tcConfigB, sourceFilesNew
 
             match loadClosureOpt with

src/fsharp/service/Reactor.fs

@@ -42,6 +42,7 @@ type Reactor() =
     let mutable culture = CultureInfo(CultureInfo.CurrentUICulture.Name)
 
     let mutable bgOpCts = new CancellationTokenSource()
+
     /// Mailbox dispatch function.
     let builder = 
         MailboxProcessor<_>.Start <| fun inbox ->
@@ -196,6 +197,7 @@ type Reactor() =
             )
             return! resultCell.AsyncResult 
         }
+
     member __.PauseBeforeBackgroundWork with get() = pauseBeforeBackgroundWork and set v = pauseBeforeBackgroundWork <- v
 
     static member Singleton = theReactor 

src/fsharp/tainted.fs

@@ -10,6 +10,13 @@ open Microsoft.FSharp.Core.CompilerServices
 open FSharp.Compiler.AbstractIL.IL
 open FSharp.Compiler.AbstractIL.Internal.Library 
 
+[<Sealed>]
+type internal TypeProviderToken() = interface LockToken
+
+[<Sealed>]
+type internal TypeProviderLock() =
+    inherit Lock<TypeProviderToken>()
+
 type internal TypeProviderError
     (
         errNum : int,
@@ -69,7 +76,7 @@ type internal TypeProviderError
             for msg in errors do
                 f (new TypeProviderError(errNum, tpDesignation, m, [msg], typeNameContext, methodNameContext))
 
-type TaintedContext = { TypeProvider : ITypeProvider; TypeProviderAssemblyRef : ILScopeRef }
+type TaintedContext = { TypeProvider : ITypeProvider; TypeProviderAssemblyRef : ILScopeRef; Lock: TypeProviderLock }
 
 [<NoEquality>][<NoComparison>] 
 type internal Tainted<'T> (context : TaintedContext, value : 'T) =
@@ -88,7 +95,7 @@ type internal Tainted<'T> (context : TaintedContext, value : 'T) =
 
     member this.Protect f  (range:range) =
         try 
-            f value
+            context.Lock.AcquireLock(fun _ -> f value)
         with
             |   :? TypeProviderError -> reraise()
             |   :? AggregateException as ae ->
@@ -143,7 +150,7 @@ type internal Tainted<'T> (context : TaintedContext, value : 'T) =
 
     static member CreateAll(providerSpecs : (ITypeProvider * ILScopeRef) list) =
         [for (tp,nm) in providerSpecs do
-             yield Tainted<_>({ TypeProvider=tp; TypeProviderAssemblyRef=nm },tp) ] 
+             yield Tainted<_>({ TypeProvider=tp; TypeProviderAssemblyRef=nm; Lock=TypeProviderLock() },tp) ] 
 
     member this.OfType<'U> () =
         match box value with

src/fsharp/tainted.fsi

@@ -10,6 +10,15 @@ open System.Reflection
 open Microsoft.FSharp.Core.CompilerServices
 open FSharp.Compiler.Range
 open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.AbstractIL.Internal.Library
+
+[<Sealed>]
+type internal TypeProviderToken = 
+    interface LockToken
+
+[<Sealed;Class>]
+type internal TypeProviderLock =
+    inherit Lock<TypeProviderToken>
 
 /// Stores and transports aggregated list of errors reported by the type provider
 type internal TypeProviderError =