Fix some underlying causes of long UI blocks in new LS implementation

src/fsharp/vs/IncrementalBuild.fs

@@ -6,6 +6,8 @@ namespace Microsoft.FSharp.Compiler
 open System
 open System.IO
 open System.Collections.Generic
+open System.Threading
+open System.Threading.Tasks
 open Microsoft.FSharp.Compiler
 open Microsoft.FSharp.Compiler.NameResolution
 open Microsoft.FSharp.Compiler.Tastops
@@ -747,44 +749,67 @@ module internal IncrementalBuild =
                 PartialBuild(bt.Rules, Map.add id (VectorResult(results)) bt.Results)
             | _ -> failwith "Unexpected"
 
-    let ExecuteApply (action:Action) bt = 
+    let mutable injectCancellationFault = false
+    let LocallyInjectCancellationFault() = 
+        injectCancellationFault <- true
+        { new IDisposable with member __.Dispose() =  injectCancellationFault <- false }
+
+    /// 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 = 
+        ct.ThrowIfCancellationRequested()
+        if (injectCancellationFault) then raise (OperationCanceledException("injected fault"))
         let actionResult = action.Execute()
-        ApplyResult(actionResult,bt)
+        let newBt = ApplyResult(actionResult,bt)
+        save newBt
+        newBt
 
     /// Evaluate the result of a single output
-    let EvalLeafsFirst target bt =
+    ///
+    /// Will throw OperationCanceledException if the cancellation token has been set.
+    let EvalLeafsFirst save (ct: CancellationToken) target bt =
 
         let rec eval(bt,gen) =
             #if DEBUG
             // This can happen, for example, if there is a task whose timestamp never stops increasing.
             // Possibly could detect this case directly.
             if gen>5000 then failwith "Infinite loop in incremental builder?"
             #endif
-            let newBt = ForeachAction target bt ExecuteApply bt
-            if newBt=bt then bt else eval(newBt,gen+1)
+            let newBt = ForeachAction target bt (ExecuteApply save ct) bt
+            if newBt=bt then  bt else eval(newBt,gen+1)
         eval(bt,0)
 
-    let Step target (bt:PartialBuild) = 
+    /// 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) = 
 
         // 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) []
 
         match worklist with 
-        | action::_ -> Some (ExecuteApply action bt)
+        | action::_ -> Some (ExecuteApply save ct action bt)
         | _ -> None
 
     /// Evaluate an output of the build.
-    let Eval node bt = EvalLeafsFirst (Target(node,None)) bt
+    ///
+    /// Will throw OperationCanceledException if the cancellation token 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
 
     /// Evaluate an output of the build.
-    let EvalUpTo (node, n) bt = EvalLeafsFirst (Target(node, Some n)) bt
+    ///
+    /// Will throw OperationCanceledException if the cancellation token 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
 
     /// Check if an output is up-to-date and ready
     let IsReady target bt = 
         let worklist = ForeachAction target bt (fun a l -> a :: l) []
         worklist.IsEmpty
-
+        
     /// Check if an output is up-to-date and ready
     let MaxTimeStampInDependencies target bt = 
         ComputeMaxTimeStamp target bt DateTime.MinValue 
@@ -1610,10 +1635,7 @@ 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 EvalAndKeepOutput f = 
-        let newPartialBuild = f partialBuild
-        partialBuild <- newPartialBuild
-        newPartialBuild
+    let SavePartialBuild b = partialBuild <- b
 
     let MaxTimeStampInDependencies (output:INode) = 
         IncrementalBuild.MaxTimeStampInDependencies output.Name partialBuild 
@@ -1650,16 +1672,15 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig
         | _ -> true                
 #endif
 
-    member __.Step () =  
-        match IncrementalBuild.Step (Target(tcStatesNode, None)) partialBuild with 
+    member __.Step (ct) =  
+        match IncrementalBuild.Step SavePartialBuild ct (Target(tcStatesNode, None)) partialBuild with 
         | None -> 
             projectChecked.Trigger()
             false
-        | Some newPartialBuild -> 
-            partialBuild <- newPartialBuild
+        | Some _ -> 
             true
 
-    member ib.GetCheckResultsBeforeFileInProjectIfReady filename: PartialCheckResults option  = 
+    member ib.GetCheckResultsBeforeFileInProjectIfReady (filename): PartialCheckResults option  = 
         let slotOfFile = ib.GetSlotOfFileName filename
         let result = 
             match slotOfFile with
@@ -1677,33 +1698,33 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig
         | (*first file*) 0 -> IncrementalBuild.IsReady (Target(initialTcAccNode, None)) partialBuild 
         | _ -> IncrementalBuild.IsReady (Target(tcStatesNode, Some (slotOfFile-1))) partialBuild  
 
-    member ib.GetCheckResultsBeforeFileInProject filename = 
+    member ib.GetCheckResultsBeforeFileInProject (filename, ct) = 
         let slotOfFile = ib.GetSlotOfFileName filename
-        ib.GetTypeCheckResultsBeforeSlotInProject slotOfFile
+        ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct)
 
-    member ib.GetCheckResultsAfterFileInProject filename = 
+    member ib.GetCheckResultsAfterFileInProject (filename, ct) = 
         let slotOfFile = ib.GetSlotOfFileName filename + 1
-        ib.GetTypeCheckResultsBeforeSlotInProject slotOfFile
+        ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct)
 
-    member ib.GetTypeCheckResultsBeforeSlotInProject slotOfFile = 
+    member ib.GetTypeCheckResultsBeforeSlotInProject (slotOfFile, ct) = 
         let result = 
             match slotOfFile with
             | (*first file*) 0 -> 
-                let build = EvalAndKeepOutput (IncrementalBuild.Eval initialTcAccNode)  
+                let build = IncrementalBuild.Eval SavePartialBuild ct initialTcAccNode partialBuild
                 GetScalarResult(initialTcAccNode,build)
             | _ -> 
-                let build = EvalAndKeepOutput (IncrementalBuild.EvalUpTo (tcStatesNode, (slotOfFile-1))) 
+                let build = IncrementalBuild.EvalUpTo 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 () = 
-        b.GetTypeCheckResultsBeforeSlotInProject(b.GetSlotsCount()) 
+    member b.GetCheckResultsAfterLastFileInProject (ct) = 
+        b.GetTypeCheckResultsBeforeSlotInProject(b.GetSlotsCount(), ct) 
 
-    member __.GetCheckResultsAndImplementationsForProject() = 
-        let build = EvalAndKeepOutput (IncrementalBuild.Eval finalizedTypeCheckNode)
+    member __.GetCheckResultsAndImplementationsForProject(ct) = 
+        let build = IncrementalBuild.Eval SavePartialBuild ct finalizedTypeCheckNode partialBuild
         match GetScalarResult(finalizedTypeCheckNode,build) with
         | Some ((ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt, tcAcc), timestamp) -> 
             PartialCheckResults.Create (tcAcc,timestamp), ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt
@@ -1731,12 +1752,12 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig
         | Some (VectorResult vr) -> vr.Size
         | _ -> failwith "Failed to find sizes"
 
-    member ib.GetParseResultsForFile filename =
+    member ib.GetParseResultsForFile (filename, ct) =
         let slotOfFile = ib.GetSlotOfFileName filename
         match GetVectorResultBySlot(parseTreesNode,slotOfFile,partialBuild) with
         | Some (results, _) -> results
         | None -> 
-            let build = EvalAndKeepOutput (IncrementalBuild.EvalUpTo (parseTreesNode, slotOfFile))  
+            let build = IncrementalBuild.EvalUpTo 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'."

src/fsharp/vs/IncrementalBuild.fsi

@@ -3,6 +3,8 @@
 namespace Microsoft.FSharp.Compiler
 
 open System
+open System.Threading
+open System.Threading.Tasks
 open Microsoft.FSharp.Compiler
 open Microsoft.FSharp.Compiler.Range
 open Microsoft.FSharp.Compiler.ErrorLogger
@@ -142,7 +144,7 @@ type internal IncrementalBuilder =
       member ThereAreLiveTypeProviders : bool
 #endif
       /// Perform one step in the F# build. Return true if the background work is finished.
-      member Step : unit -> bool
+      member Step : 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.
@@ -158,33 +160,33 @@ type internal IncrementalBuilder =
       /// 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 -> PartialCheckResults 
+      member GetCheckResultsBeforeFileInProject : 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 -> PartialCheckResults 
+      member GetCheckResultsAfterFileInProject : 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 : unit -> PartialCheckResults 
+      member GetCheckResultsAfterLastFileInProject : 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 : unit -> PartialCheckResults * IL.ILAssemblyRef * IRawFSharpAssemblyData option * TypedImplFile list option
+      member GetCheckResultsAndImplementationsForProject : 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
 
       /// 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 -> Ast.ParsedInput option * Range.range * string * (PhasedError * FSharpErrorSeverity) list
+      member GetParseResultsForFile : filename:string * ct: CancellationToken -> Ast.ParsedInput option * Range.range * string * (PhasedError * 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 
 
@@ -242,14 +244,17 @@ module internal IncrementalBuild =
 
     type Target = Target of INode * int  option
 
+    /// Used for unit testing. Causes all steps of underlying incremental graph evaluation to throw OperationCanceledException
+    val LocallyInjectCancellationFault : unit -> IDisposable
+
     /// Evaluate a build. Only required for unit testing.
-    val Eval : INode -> PartialBuild -> PartialBuild
+    val Eval : (PartialBuild -> unit) -> CancellationToken -> INode -> PartialBuild -> PartialBuild
 
     /// Evaluate a build for a vector up to a limit. Only required for unit testing.
-    val EvalUpTo : INode * int -> PartialBuild -> PartialBuild
+    val EvalUpTo : (PartialBuild -> unit) -> CancellationToken -> INode * int -> PartialBuild -> PartialBuild
 
     /// Do one step in the build. Only required for unit testing.
-    val Step : Target -> PartialBuild -> PartialBuild option
+    val Step : (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.

src/fsharp/vs/Reactor.fs

@@ -141,6 +141,7 @@ type Reactor() =
                         try
                             f ct |> AsyncUtil.AsyncOk
                         with
+                        |   :? OperationCanceledException as e -> AsyncUtil.AsyncCanceled e
                         |   e -> e |> AsyncUtil.AsyncException
                     resultCell.RegisterResult(result)),
                     ccont=(fun () -> resultCell.RegisterResult (AsyncUtil.AsyncCanceled(OperationCanceledException())) )