Add IReactorListener interface

fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj

@@ -594,6 +594,12 @@
     <Compile Include="$(FSharpSourcesRoot)\fsharp\symbols\SymbolPatterns.fs">
       <Link>Symbols/SymbolPatterns.fs</Link>
     </Compile>
+    <Compile Include="$(FSharpSourcesRoot)\fsharp\service\ReactorListener.fsi">
+      <Link>Service/ReactorListener.fsi</Link>
+    </Compile>
+    <Compile Include="$(FSharpSourcesRoot)\fsharp\service\ReactorListener.fs">
+      <Link>Service/ReactorListener.fs</Link>
+    </Compile>
     <Compile Include="$(FSharpSourcesRoot)\fsharp\service\Reactor.fsi">
       <Link>Service/Reactor.fsi</Link>
     </Compile>

src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj

@@ -582,6 +582,12 @@
     <Compile Include="..\symbols\SymbolPatterns.fs">
       <Link>Symbols/SymbolPatterns.fs</Link>
     </Compile>
+    <Compile Include="$(FSharpSourcesRoot)\fsharp\service\ReactorListener.fsi">
+      <Link>Service/ReactorListener.fsi</Link>
+    </Compile>
+    <Compile Include="$(FSharpSourcesRoot)\fsharp\service\ReactorListener.fs">
+      <Link>Service/ReactorListener.fs</Link>
+    </Compile>
     <Compile Include="..\service\Reactor.fsi">
       <Link>Service/Reactor.fsi</Link>
     </Compile>

src/fsharp/service/Reactor.fs

@@ -35,6 +35,9 @@ type internal ReactorCommands =
 type Reactor() = 
     static let pauseBeforeBackgroundWorkDefault = GetEnvInteger "FCS_PauseBeforeBackgroundWorkMilliseconds" 10
     static let theReactor = Reactor()
+
+    let mutable listener: IReactorListener = DefaultReactorListener() :> _
+
     let mutable pauseBeforeBackgroundWork = pauseBeforeBackgroundWorkDefault
 
     // We need to store the culture for the VS thread that is executing now, 
@@ -64,8 +67,8 @@ type Reactor() =
                                 | Some _, _ -> 
                                     let timeout = 
                                         if bg then 0 
-                                        else 
-                                            Trace.TraceInformation("Reactor: {0:n3} pausing {1} milliseconds", DateTime.Now.TimeOfDay.TotalSeconds, pauseBeforeBackgroundWork)
+                                        else
+                                            listener.OnReactorPauseBeforeBackgroundWork pauseBeforeBackgroundWork
                                             pauseBeforeBackgroundWork
                                     return! inbox.TryReceive(timeout) }
                     Thread.CurrentThread.CurrentUICulture <- culture
@@ -76,16 +79,14 @@ type Reactor() =
 
                     | Some (Op (userOpName, opName, opArg, ct, op, ccont)) -> 
                         if ct.IsCancellationRequested then ccont() else
-                        Trace.TraceInformation("Reactor: {0:n3} --> {1}.{2} ({3}), remaining {4}", DateTime.Now.TimeOfDay.TotalSeconds, userOpName, opName, opArg, inbox.CurrentQueueLength)
+                        listener.OnReactorOperationStart userOpName opName opArg inbox.CurrentQueueLength
                         let time = Stopwatch()
-                        time.Start()
-                        op ctok
-                        time.Stop()
-                        let span = time.Elapsed
-                        //if span.TotalMilliseconds > 100.0 then 
-                        let taken = span.TotalMilliseconds
-                        let msg = (if taken > 10000.0 then "BAD-OP: >10s " elif taken > 3000.0 then "BAD-OP: >3s " elif taken > 1000.0 then "BAD-OP: > 1s " elif taken > 500.0 then "BAD-OP: >0.5s " else "")
-                        Trace.TraceInformation("Reactor: {0:n3} {1}<-- {2}.{3}, took {4} ms", DateTime.Now.TimeOfDay.TotalSeconds, msg, userOpName, opName, span.TotalMilliseconds)
+                        try
+                            time.Start()
+                            op ctok
+                            time.Stop()
+                        finally
+                            listener.OnReactorOperationEnd userOpName opName opArg time.Elapsed
                         return! loop (bgOpOpt, onComplete, false)
                     | Some (WaitForBackgroundOpCompletion channel) -> 
                         match bgOpOpt with 
@@ -110,20 +111,22 @@ type Reactor() =
                     | None -> 
                         match bgOpOpt, onComplete with 
                         | _, Some onComplete -> onComplete.Reply()
-                        | Some  (bgUserOpName, bgOpName, bgOpArg, bgOp), None -> 
-                            Trace.TraceInformation("Reactor: {0:n3} --> background step {1}.{2} ({3})", DateTime.Now.TimeOfDay.TotalSeconds, bgUserOpName, bgOpName, bgOpArg)
+                        | Some  (bgUserOpName, bgOpName, bgOpArg, bgOp), None ->
+                            listener.OnReactorBackgroundStart bgUserOpName bgOpName bgOpArg
                             let time = Stopwatch()
-                            time.Start()
-                            bgOpCts.Dispose()
-                            bgOpCts <- new CancellationTokenSource()
-                            let res = bgOp ctok bgOpCts.Token
-                            if bgOpCts.IsCancellationRequested then 
-                                Trace.TraceInformation("FCS: <-- background step {0}.{1}, was cancelled", bgUserOpName, bgOpName)
-                            time.Stop()
-                            let taken = time.Elapsed.TotalMilliseconds
-                            //if span.TotalMilliseconds > 100.0 then 
-                            let msg = (if taken > 10000.0 then "BAD-BG-SLICE: >10s " elif taken > 3000.0 then "BAD-BG-SLICE: >3s " elif taken > 1000.0 then "BAD-BG-SLICE: > 1s " else "")
-                            Trace.TraceInformation("Reactor: {0:n3} {1}<-- background step, took {2}ms", DateTime.Now.TimeOfDay.TotalSeconds, msg, taken)
+                            let res =
+                                try
+                                    time.Start()
+                                    bgOpCts.Dispose()
+                                    bgOpCts <- new CancellationTokenSource()
+                                    let res = bgOp ctok bgOpCts.Token
+                                    time.Stop()
+                                    if bgOpCts.IsCancellationRequested then 
+                                        listener.OnReactorBackgroundCancelled bgUserOpName bgOpName bgOpArg
+                                    res
+                                finally
+                                    listener.OnReactorBackgroundEnd bgUserOpName bgOpName bgOpArg time.Elapsed
+
                             return! loop ((if res then bgOpOpt else None), onComplete, true)
                         | None, None -> failwith "unreachable, should have used inbox.Receive"
                     }
@@ -147,26 +150,29 @@ type Reactor() =
         | None -> ()
 
     // [Foreground Mailbox Accessors] -----------------------------------------------------------                
-    member r.SetBackgroundOp(bgOpOpt) = 
-        Trace.TraceInformation("Reactor: {0:n3} enqueue start background, length {1}", DateTime.Now.TimeOfDay.TotalSeconds, builder.CurrentQueueLength)
+    member r.SetBackgroundOp(bgOpOpt) =
+        listener.OnSetBackgroundOp builder.CurrentQueueLength
         bgOpCts.Cancel()
         builder.Post(SetBackgroundOp bgOpOpt)
 
     member r.CancelBackgroundOp() = 
-        Trace.TraceInformation("FCS: trying to cancel any active background work")
+        listener.OnCancelBackgroundOp()
         bgOpCts.Cancel()
 
     member r.EnqueueOp(userOpName, opName, opArg, op) =
-        Trace.TraceInformation("Reactor: {0:n3} enqueue {1}.{2} ({3}), length {4}", DateTime.Now.TimeOfDay.TotalSeconds, userOpName, opName, opArg, builder.CurrentQueueLength)
+        listener.OnEnqueueOp userOpName opName opArg builder.CurrentQueueLength
         builder.Post(Op(userOpName, opName, opArg, CancellationToken.None, op, (fun () -> ()))) 
 
     member r.EnqueueOpPrim(userOpName, opName, opArg, ct, op, ccont) =
-        Trace.TraceInformation("Reactor: {0:n3} enqueue {1}.{2} ({3}), length {4}", DateTime.Now.TimeOfDay.TotalSeconds, userOpName, opName, opArg, builder.CurrentQueueLength)
+        listener.OnEnqueueOp userOpName opName opArg builder.CurrentQueueLength
         builder.Post(Op(userOpName, opName, opArg, ct, op, ccont)) 
 
     member r.CurrentQueueLength =
         builder.CurrentQueueLength
 
+    member r.SetListener(newListener) =
+        listener <- newListener
+
     // This is for testing only
     member r.WaitForBackgroundOpCompletion() =
         Trace.TraceInformation("Reactor: {0:n3} enqueue wait for background, length {0}", DateTime.Now.TimeOfDay.TotalSeconds, builder.CurrentQueueLength)

src/fsharp/service/Reactor.fsi

@@ -45,6 +45,9 @@ type internal Reactor =
     /// For debug purposes
     member CurrentQueueLength : int
 
+    /// Override the current reactor event listener.
+    member SetListener : IReactorListener -> unit
+
     /// Put the operation in the queue, and return an async handle to its result. 
     member EnqueueAndAwaitOpAsync : userOpName:string * opName:string * opArg:string * (CompilationThreadToken -> Cancellable<'T>) -> Async<'T>
 

src/fsharp/service/ReactorListener.fs

@@ -0,0 +1,55 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.SourceCodeServices
+
+open System
+open System.Diagnostics
+
+type public IReactorListener =
+    abstract OnReactorPauseBeforeBackgroundWork : pauseMillis: int -> unit
+    abstract OnReactorOperationStart : userOpName: string -> opName: string -> opArg: string -> approxQueueLength: int -> unit
+    abstract OnReactorOperationEnd : userOpName: string -> opName: string -> opArg: string -> elapsed: TimeSpan -> unit
+    abstract OnReactorBackgroundStart: bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> unit
+    abstract OnReactorBackgroundCancelled : bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> unit
+    abstract OnReactorBackgroundEnd : bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> elapsed: TimeSpan -> unit
+
+    abstract OnSetBackgroundOp : approxQueueLength: int -> unit
+    abstract OnCancelBackgroundOp : unit -> unit
+    abstract OnEnqueueOp : userOpName: string -> opName: string -> opArg: string -> approxQueueLength: int -> unit
+
+type public EmptyReactorListener() =
+    interface IReactorListener with
+        override _.OnReactorPauseBeforeBackgroundWork _ = ()
+        override _.OnReactorOperationStart _ _ _ _  = ()
+        override _.OnReactorOperationEnd _ _ _ _ = ()
+        override _.OnReactorBackgroundStart _ _ _ = ()
+        override _.OnReactorBackgroundCancelled _ _ _ = ()
+        override _.OnReactorBackgroundEnd _ _ _ _ = ()
+        override _.OnSetBackgroundOp _ = ()
+        override _.OnCancelBackgroundOp () = ()
+        override _.OnEnqueueOp _ _ _ _ = ()
+
+type public DefaultReactorListener() =
+    interface IReactorListener with
+        override _.OnReactorPauseBeforeBackgroundWork pauseMillis =
+            Trace.TraceInformation("Reactor: {0:n3} pausing {1} milliseconds", DateTime.Now.TimeOfDay.TotalSeconds, pauseMillis)
+        override _.OnReactorOperationStart userOpName opName opArg approxQueueLength =
+            Trace.TraceInformation("Reactor: {0:n3} --> {1}.{2} ({3}), remaining {4}", DateTime.Now.TimeOfDay.TotalSeconds, userOpName, opName, opArg, approxQueueLength)
+        override _.OnReactorOperationEnd userOpName opName _opArg elapsed =
+            let taken = elapsed.TotalMilliseconds
+            let msg = (if taken > 10000.0 then "BAD-OP: >10s " elif taken > 3000.0 then "BAD-OP: >3s " elif taken > 1000.0 then "BAD-OP: > 1s " elif taken > 500.0 then "BAD-OP: >0.5s " else "")
+            Trace.TraceInformation("Reactor: {0:n3} {1}<-- {2}.{3}, took {4} ms", DateTime.Now.TimeOfDay.TotalSeconds, msg, userOpName, opName, taken)
+        override _.OnReactorBackgroundStart bgUserOpName bgOpName bgOpArg =
+            Trace.TraceInformation("Reactor: {0:n3} --> background step {1}.{2} ({3})", DateTime.Now.TimeOfDay.TotalSeconds, bgUserOpName, bgOpName, bgOpArg)
+        override _.OnReactorBackgroundCancelled bgUserOpName bgOpName _bgOpArg =
+            Trace.TraceInformation("FCS: <-- background step {0}.{1}, was cancelled", bgUserOpName, bgOpName)
+        override _.OnReactorBackgroundEnd _bgUserOpName _bgOpName _bgOpArg elapsed =
+            let taken = elapsed.TotalMilliseconds
+            let msg = (if taken > 10000.0 then "BAD-BG-SLICE: >10s " elif taken > 3000.0 then "BAD-BG-SLICE: >3s " elif taken > 1000.0 then "BAD-BG-SLICE: > 1s " else "")
+            Trace.TraceInformation("Reactor: {0:n3} {1}<-- background step, took {2} ms", DateTime.Now.TimeOfDay.TotalSeconds, msg, taken)
+        override _.OnSetBackgroundOp approxQueueLength =
+            Trace.TraceInformation("Reactor: {0:n3} enqueue start background, length {1}", DateTime.Now.TimeOfDay.TotalSeconds, approxQueueLength)
+        override _.OnCancelBackgroundOp () =
+            Trace.TraceInformation("FCS: trying to cancel any active background work")
+        override _.OnEnqueueOp userOpName opName opArg approxQueueLength =
+            Trace.TraceInformation("Reactor: {0:n3} enqueue {1}.{2} ({3}), length {4}", DateTime.Now.TimeOfDay.TotalSeconds, userOpName, opName, opArg, approxQueueLength)

src/fsharp/service/ReactorListener.fsi

@@ -0,0 +1,59 @@
+// Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
+
+namespace FSharp.Compiler.SourceCodeServices
+
+open System
+
+/// Interface for listening to events on the FCS reactor thread.
+type public IReactorListener =
+    /// Called when the reactor queue is empty, but there is background work to be done.
+    /// If no foreground work appears in the queue in the next <paramref name="pauseMillis"/> milliseconds, the background work will start.
+    /// Always called from the reactor thread.
+    abstract OnReactorPauseBeforeBackgroundWork : pauseMillis: int -> unit
+
+    /// Called when a foreground reactor operation starts.
+    /// Always called from the reactor thread.
+    abstract OnReactorOperationStart : userOpName: string -> opName: string -> opArg: string -> approxQueueLength: int -> unit
+
+    /// Called when a foreground reactor operation ends.
+    /// Always called from the reactor thread.
+    abstract OnReactorOperationEnd : userOpName: string -> opName: string -> opArg: string -> elapsed: TimeSpan -> unit
+
+    /// Called when a background reactor operation starts.
+    /// Always called from the reactor thread.
+    abstract OnReactorBackgroundStart: bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> unit
+
+    /// Called when a background operation is cancelled.
+    /// Always called from the reactor thread.
+    abstract OnReactorBackgroundCancelled : bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> unit
+
+    /// Called when a background operation ends.
+    /// This is still called even if the operation was cancelled.
+    /// Always called from the reactor thread.
+    abstract OnReactorBackgroundEnd : bgUserOpName: string -> bgOpName: string -> bgOpArg: string -> elapsed: TimeSpan -> unit
+
+    /// Called when a background operation is set.
+    /// This can be called from ANY thread - implementations must be thread safe.
+    abstract OnSetBackgroundOp : approxQueueLength: int -> unit
+
+    /// Called when a background operation is requested to be cancelled.
+    /// This can be called from ANY thread - implementations must be thread safe.
+    abstract OnCancelBackgroundOp : unit -> unit
+
+    /// Called when an operation is queued to be ran on the reactor.
+    /// This can be called from ANY thread - implementations must be thread safe.
+    abstract OnEnqueueOp : userOpName: string -> opName: string -> opArg: string -> approxQueueLength: int -> unit
+
+/// Reactor listener that does nothing.
+/// Should be used as a base class for any implementers of IReactorListener.
+[<Class>]
+type public EmptyReactorListener =
+    new : unit -> EmptyReactorListener
+    interface IReactorListener
+
+/// Default reactor listener.
+/// Writes debug output using <see cref="System.Diagnostics.Trace" />
+[<Class>]
+type public DefaultReactorListener =
+    new : unit -> DefaultReactorListener
+    interface IReactorListener

src/fsharp/service/service.fs

@@ -252,6 +252,7 @@ type ScriptClosureCacheToken() = interface LockToken
 type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses, enableBackgroundItemKeyStoreAndSemanticClassification) as self =
     // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor
     let reactor = Reactor.Singleton
+
     let beforeFileChecked = Event<string * obj option>()
     let fileParsed = Event<string * obj option>()
     let fileChecked = Event<string * obj option>()
@@ -978,7 +979,7 @@ type FSharpChecker(legacyReferenceResolver,
     let maxMemEvent = new Event<unit>()
 
     /// Instantiate an interactive checker.    
-    static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot, ?suggestNamesForErrors, ?keepAllBackgroundSymbolUses, ?enableBackgroundItemKeyStoreAndSemanticClassification) = 
+    static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot, ?suggestNamesForErrors, ?keepAllBackgroundSymbolUses, ?enableBackgroundItemKeyStoreAndSemanticClassification, ?reactorListenerOpt: IReactorListener) = 
 
         let legacyReferenceResolver = 
             match legacyReferenceResolver with
@@ -992,6 +993,11 @@ type FSharpChecker(legacyReferenceResolver,
         let suggestNamesForErrors = defaultArg suggestNamesForErrors false
         let keepAllBackgroundSymbolUses = defaultArg keepAllBackgroundSymbolUses true
         let enableBackgroundItemKeyStoreAndSemanticClassification = defaultArg enableBackgroundItemKeyStoreAndSemanticClassification false
+
+        match reactorListenerOpt with
+        | None -> ()
+        | Some reactorListener -> Reactor.Singleton.SetListener reactorListener
+
         new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses, enableBackgroundItemKeyStoreAndSemanticClassification)
 
     member __.ReferenceResolver = legacyReferenceResolver

src/fsharp/service/service.fsi

@@ -75,7 +75,8 @@ type public FSharpChecker =
     /// <param name="keepAllBackgroundResolutions">If false, do not keep full intermediate checking results from background checking suitable for returning from GetBackgroundCheckResultsForFileInProject. This reduces memory usage.</param>
     /// <param name="legacyReferenceResolver">An optional resolver for non-file references, for legacy purposes</param>
     /// <param name="tryGetMetadataSnapshot">An optional resolver to access the contents of .NET binaries in a memory-efficient way</param>
-    static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool  * ?legacyReferenceResolver: ReferenceResolver.Resolver * ?tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot * ?suggestNamesForErrors: bool * ?keepAllBackgroundSymbolUses: bool * ?enableBackgroundItemKeyStoreAndSemanticClassification: bool -> FSharpChecker
+    /// <param name="reactorListener">An optional listener to monitor reactor thread events. Overrides any existing reactor listener</param>
+    static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool  * ?legacyReferenceResolver: ReferenceResolver.Resolver * ?tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot * ?suggestNamesForErrors: bool * ?keepAllBackgroundSymbolUses: bool * ?enableBackgroundItemKeyStoreAndSemanticClassification: bool * ?reactorListener: IReactorListener -> FSharpChecker
 
     /// <summary>
     ///   Parse a source code file, returning information about brace matching in the file.