Skip to content

Commit d9e7ce0

Browse files
dsymedsyme
committed
rewrite of reactor
1 parent fc750d3 commit d9e7ce0

File tree

5 files changed

+89
-205
lines changed

5 files changed

+89
-205
lines changed

‎src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@
3939
<DefineConstants>$(DefineConstants);COMPILER</DefineConstants>
4040
<DefineConstants>$(DefineConstants);EXTENSIONTYPING</DefineConstants>
4141
<DefineConstants>$(DefineConstants);NO_STRONG_NAMES</DefineConstants>
42+
<DefineConstants>$(DefineConstants);TRACE</DefineConstants>
4243
<TargetFSharpCoreVersion>4.3.0.0</TargetFSharpCoreVersion>
4344
<SolutionDir Condition="$(SolutionDir) == '' Or $(SolutionDir) == '*Undefined*'">..\..\..\</SolutionDir>
4445
<TargetFrameworkProfile />

‎src/fsharp/vs/Reactor.fs‎

Lines changed: 62 additions & 175 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
namespace Microsoft.FSharp.Compiler.SourceCodeServices
44
open System
55
open System.Diagnostics
6+
open System.Globalization
67
open System.Threading
78
open Microsoft.FSharp.Control
89
open Microsoft.FSharp.Compiler.Lib
@@ -14,207 +15,90 @@ type internal IReactorOperations =
1415

1516
module internal Reactor =
1617

17-
type ResultOrException<'TResult> =
18-
| Result of 'TResult
19-
| Exception of System.Exception
20-
2118
[<NoEquality; NoComparison>]
2219
type ReactorCommands =
2320
/// Kick off a build.
24-
| StartBackgroundOp of (unit -> bool)
25-
/// Do a bit of work on the given build.
26-
| Step
21+
| SetBackgroundOp of (unit -> bool) option
2722
/// Do some work not synchronized in the mailbox.
2823
| Op of string * CancellationToken * (unit -> unit) * (unit -> unit)
29-
/// Stop building after finishing the current unit of work.
30-
| StopBackgroundOp of AsyncReplyChannel<ResultOrException<unit>>
31-
/// Finish building.
32-
| FinishBackgroundOp of AsyncReplyChannel<ResultOrException<unit>>
33-
override rc.ToString() =
34-
match rc with
35-
| StartBackgroundOp _->"StartBackgroundOp"
36-
| Step->"Step"
37-
| Op _->"Op"
38-
| StopBackgroundOp _->"StopBackgroundOp"
39-
| FinishBackgroundOp _->"FinishBackgroundOp"
24+
/// Finish the background building
25+
| WaitForBackgroundOpCompletion of AsyncReplyChannel<unit>
26+
/// Finish all the queued ops
27+
| CompleteAllQueuedOps of AsyncReplyChannel<unit>
4028

41-
[<NoEquality; NoComparison>]
42-
type ReactorState =
43-
| Idling
44-
| ActivelyBuilding of (unit -> bool)
45-
| FinishingBuild of (unit -> bool) * AsyncReplyChannel<ResultOrException<unit>>
46-
/// An exception was seen in a prior state. The exception is preserved so it can be thrown back to the calling thread.
47-
| BackgroundError of Exception
48-
override rs.ToString() =
49-
match rs with
50-
| Idling->"Idling"
51-
| ActivelyBuilding _->"ActivelyBuilding"
52-
| FinishingBuild _->"FinishingBuild"
53-
| BackgroundError _->"BackgroundError"
54-
5529
[<AutoSerializable(false);Sealed>]
5630
/// There is one global Reactor for the entire language service, no matter how many projects or files
5731
/// are open.
5832
type Reactor() =
5933
// We need to store the culture for the VS thread that is executing now,
6034
// so that when the reactor picks up a thread from the threadpool we can set the culture
61-
#if SILVERLIGHT
62-
let culture = System.Threading.Thread.CurrentThread.CurrentCulture
63-
#else
64-
let culture = new System.Globalization.CultureInfo(System.Threading.Thread.CurrentThread.CurrentUICulture.LCID)
65-
#endif
66-
67-
// Post an exception back to FinishingBuild channel.
68-
let UnexpectedFinishingBuild commandName (channel: AsyncReplyChannel<_>) =
69-
channel.Reply(Exception (new Exception(sprintf "[Bug]Did not expect %s during FinishingBuild." commandName)))
70-
71-
// Kick off a build.
72-
let HandleStartBackgroundOp (inbox: MailboxProcessor<_>) build state =
73-
inbox.Post Step
74-
match state with
75-
| ActivelyBuilding _oldBuild -> ActivelyBuilding build // replace the background build
76-
| Idling -> ActivelyBuilding build // start the background build
77-
| FinishingBuild _ -> state // ignore the request for a new background build
78-
| BackgroundError _ -> state // ignore the request for a new background build until error is reported
79-
80-
// Stop the build.
81-
let HandleStopBackgroundOp (channel:AsyncReplyChannel<_>) state =
82-
match state with
83-
| ActivelyBuilding _oldBuild -> channel.Reply(Result ())
84-
| Idling -> channel.Reply(Result ())
85-
| FinishingBuild(_, channel) -> UnexpectedFinishingBuild "StopBackgroundOp" channel
86-
| BackgroundError e-> channel.Reply(Exception e)
87-
88-
Idling
89-
90-
// Interleave the given operation with other work
91-
let HandleOp op state =
92-
try
93-
op()
94-
state
95-
with e ->
96-
System.Diagnostics.Debug.Assert(false, sprintf "Bug in target of HandleOp: %A: %s\nThe most recent error reported to an error scope: %+A\n" (e.GetType()) e.Message e.StackTrace)
97-
state
98-
99-
// Do a step in the build.
100-
let HandleStep (inbox: MailboxProcessor<_>) state =
101-
match state with
102-
| FinishingBuild(build,_)
103-
| ActivelyBuilding(build) ->
104-
105-
// Gather any required reply channel.
106-
let replyChannel =
107-
match state with
108-
| Idling | ActivelyBuilding _ | BackgroundError _ -> None
109-
| FinishingBuild(_,channel) -> Some channel
110-
111-
try
112-
if build() then
113-
// More work
114-
inbox.Post Step
115-
state
116-
else
117-
// Work is done. Reply if there is a channel for it.
118-
match replyChannel with
119-
| Some(replyChannel)-> replyChannel.Reply(Result ())
120-
| None->()
121-
122-
// Switch to idle state.
123-
Idling
124-
with e->
125-
System.Diagnostics.Debug.Assert(false, sprintf "[Bug]Failure in HandleStep: %s" (e.ToString()))
126-
match replyChannel with
127-
| Some(replyChannel)->
128-
replyChannel.Reply(Exception e)
129-
Idling
130-
| None->BackgroundError e
131-
132-
| Idling -> Idling
133-
134-
| BackgroundError _ -> state
135-
136-
137-
let HandleFinishBackgroundO (inbox: MailboxProcessor<_>) (channel:AsyncReplyChannel<_>) state =
138-
match state with
139-
| ActivelyBuilding(build) ->
140-
inbox.Post Step
141-
FinishingBuild(build,channel)
142-
143-
| FinishingBuild(_, channelOld) ->
144-
// Don't expect to get here. If this is required then we need to keep all channels and post back to each
145-
// when the build finishes. For now, throw an exception back.
146-
UnexpectedFinishingBuild "FinishBackgroundOping" channel
147-
UnexpectedFinishingBuild "FinishBackgroundOping" channelOld
148-
Idling
149-
150-
| Idling ->
151-
channel.Reply(Result ())
152-
Idling
35+
let culture = new CultureInfo(Thread.CurrentThread.CurrentUICulture.LCID)
15336

154-
| BackgroundError e ->
155-
// We have a waiting channel to post our exception to.
156-
channel.Reply(Exception e)
157-
Idling
158-
15937
/// Mailbox dispatch function.
16038
let builder =
16139
MailboxProcessor<_>.Start <| fun inbox ->
16240

41+
16342
// Async workflow which receives messages and dispatches to worker functions.
164-
let rec loop (state: ReactorState) =
43+
let rec loop (bgOpOpt, onComplete) =
16544
async { Debug.WriteLine("Reactor: receiving..., remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
166-
let! msg = inbox.Receive()
167-
System.Threading.Thread.CurrentThread.CurrentUICulture <- culture
168-
169-
let newState =
170-
try
171-
match msg with
172-
| StartBackgroundOp build ->
173-
Debug.WriteLine("Reactor: --> start background, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
174-
HandleStartBackgroundOp inbox build state
175-
| Step ->
45+
46+
// Messages always have priority over the background op.
47+
let! msg =
48+
async { match bgOpOpt, onComplete with
49+
| None, None -> let! msg = inbox.Receive() in return Some msg
50+
| _ -> return! inbox.TryReceive(0) }
51+
Thread.CurrentThread.CurrentUICulture <- culture
52+
53+
match msg with
54+
| Some (SetBackgroundOp bgOpOpt) ->
55+
Debug.WriteLine("Reactor: --> set background op, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
56+
return! loop (bgOpOpt, onComplete)
57+
| Some (Op (desc, ct, op, ccont)) ->
58+
if ct.IsCancellationRequested then ccont() else
59+
Debug.WriteLine("Reactor: --> {0}, remaining {1}, mem {2}, gc2 {3}", desc, inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
60+
let time = System.DateTime.Now
61+
op()
62+
let span = System.DateTime.Now - time
63+
//if span.TotalMilliseconds > 100.0 then
64+
Debug.WriteLine("Reactor: <-- {0}, remaining {1}, took {2}ms", desc, inbox.CurrentQueueLength, span.TotalMilliseconds)
65+
return! loop (bgOpOpt, onComplete)
66+
| Some (WaitForBackgroundOpCompletion channel) ->
67+
Debug.WriteLine("Reactor: --> wait for background (debug only), remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
68+
match bgOpOpt with
69+
| None -> ()
70+
| Some bgOp -> while bgOp() do ()
71+
channel.Reply(())
72+
return! loop (None, onComplete)
73+
| Some (CompleteAllQueuedOps channel) ->
74+
Debug.WriteLine("Reactor: --> stop background work and complete all queued ops, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
75+
return! loop (None, Some channel)
76+
| None ->
77+
match bgOpOpt, onComplete with
78+
| _, Some onComplete -> onComplete.Reply()
79+
| Some bgOp, None ->
17680
Debug.WriteLine("Reactor: --> background step, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
17781
let time = System.DateTime.Now
178-
let res = HandleStep inbox state
82+
let res = bgOp()
17983
let span = System.DateTime.Now - time
18084
//if span.TotalMilliseconds > 100.0 then
18185
Debug.WriteLine("Reactor: <-- background step, remaining {0}, took {1}ms", inbox.CurrentQueueLength, span.TotalMilliseconds)
182-
res
183-
| Op (desc, ct, op, ccont) ->
184-
if ct.IsCancellationRequested then ccont(); state else
185-
Debug.WriteLine("Reactor: --> {0}, remaining {1}, mem {2}, gc2 {3}", desc, inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
186-
let time = System.DateTime.Now
187-
let res = HandleOp op state
188-
let span = System.DateTime.Now - time
189-
//if span.TotalMilliseconds > 100.0 then
190-
Debug.WriteLine("Reactor: <-- {0}, remaining {1}, took {2}ms", desc, inbox.CurrentQueueLength, span.TotalMilliseconds)
191-
res
192-
| StopBackgroundOp channel ->
193-
Debug.WriteLine("Reactor: --> stop background, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
194-
HandleStopBackgroundOp channel state
195-
| FinishBackgroundOp channel ->
196-
Debug.WriteLine("Reactor: --> finish background, remaining {0}, mem {1}, gc2 {2}", inbox.CurrentQueueLength, GC.GetTotalMemory(false)/1000000L, GC.CollectionCount(2))
197-
HandleFinishBackgroundO inbox channel state
198-
with e ->
199-
Debug.Assert(false,"unexpected failure in reactor loop")
200-
state
201-
202-
return! loop newState
86+
return! loop ((if res then None else Some bgOp), onComplete)
87+
| None, None -> failwith "unreachable, should have used inbox.Receive"
20388
}
204-
loop Idling
89+
async {
90+
while true do
91+
try
92+
do! loop (None, None)
93+
with e ->
94+
Debug.Assert(false,String.Format("unexpected failure in reactor loop {0}, restarting", e))
95+
}
20596

20697

20798
// [Foreground Mailbox Accessors] -----------------------------------------------------------
208-
member r.StartBackgroundOp(build) =
99+
member r.SetBackgroundOp(build) =
209100
Debug.WriteLine("Reactor: enqueue start background, length {0}", builder.CurrentQueueLength)
210-
builder.Post(StartBackgroundOp build)
211-
212-
member r.StopBackgroundOp() =
213-
Debug.WriteLine("Reactor: enqueue stop background, length {0}", builder.CurrentQueueLength)
214-
match builder.PostAndReply(fun replyChannel->StopBackgroundOp(replyChannel)) with
215-
| Result result->result
216-
| Exception excn->
217-
raise excn
101+
builder.Post(SetBackgroundOp build)
218102

219103
member r.EnqueueOp(desc, op) =
220104
Debug.WriteLine("Reactor: enqueue {0}, length {1}", desc, builder.CurrentQueueLength)
@@ -230,9 +114,12 @@ module internal Reactor =
230114
// This is for testing only
231115
member r.WaitForBackgroundOpCompletion() =
232116
Debug.WriteLine("Reactor: enqueue wait for background, length {0}", builder.CurrentQueueLength)
233-
match builder.PostAndReply(fun replyChannel->FinishBackgroundOp(replyChannel)) with
234-
| Result result->result
235-
| Exception excn->raise excn
117+
builder.PostAndReply WaitForBackgroundOpCompletion
118+
119+
// This is for testing only
120+
member r.CompleteAllQueuedOps() =
121+
Debug.WriteLine("Reactor: enqueue wait for background, length {0}", builder.CurrentQueueLength)
122+
builder.PostAndReply WaitForBackgroundOpCompletion
236123

237124
member r.EnqueueAndAwaitOpAsync (desc, f) =
238125
async {

‎src/fsharp/vs/Reactor.fsi‎

Lines changed: 8 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -24,27 +24,23 @@ module internal Reactor =
2424
[<Sealed>]
2525
type Reactor =
2626

27-
/// Start background building using the given build function, which is called repeatedly
28-
/// until it returns 'false'
29-
member StartBackgroundOp : build:(unit -> bool) -> unit
27+
/// Set the background building function, which is called repeatedly
28+
/// until it returns 'false'. If None then no background operation is used.
29+
member SetBackgroundOp : build:(unit -> bool) option -> unit
3030

31-
/// Halt the current implicit background operation
32-
member StopBackgroundOp : unit -> unit
33-
34-
/// Block until the current implicit background build is complete.
31+
/// Block until the current implicit background build is complete. Unit test only.
3532
member WaitForBackgroundOpCompletion : unit -> unit
3633

34+
/// Block until all operations in the queue are complete
35+
member CompleteAllQueuedOps : unit -> unit
36+
3737
/// Enqueue an uncancellable operation and return immediately.
3838
member EnqueueOp : description: string * op:(unit -> unit) -> unit
3939

4040
/// For debug purposes
4141
member CurrentQueueLength : int
42-
43-
// TODO: For all AsyncOps: if the operation gets cancelled, the background thread and Reactor don't abandon their work,
44-
// even when it is ultimately an Eventually<_> compuation which could easily be abandoned, or an IncrementalBuild.Eval
45-
// operation which can be halted part way through.
4642

47-
/// Put the operation in thq queue, and return an async handle to its result.
43+
/// Put the operation in the queue, and return an async handle to its result.
4844
member EnqueueAndAwaitOpAsync : description: string * (CancellationToken -> 'T) -> Async<'T>
4945

5046
/// Get the reactor for FSharp.Compiler.dll

‎src/fsharp/vs/SimpleServices.fs‎

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -262,9 +262,6 @@ namespace Microsoft.FSharp.Compiler.SimpleSourceCodeServices
262262
member x.ParseAndCheckScript (filename, source, ?otherFlags) =
263263
async {
264264
let! options = checker.GetProjectOptionsFromScript(filename, source, loadTime, ?otherFlags=otherFlags)
265-
checker.StartBackgroundCompile options
266-
// wait for the antecedent to appear
267-
checker.WaitForBackgroundCompile()
268265
// do an typecheck
269266
let textSnapshotInfo = "" // TODO
270267
let! parseResults, checkResults = checker.ParseAndCheckFileInProject(filename, fileversion, source, options, IsResultObsolete (fun _ -> false), textSnapshotInfo)

0 commit comments

Comments
 (0)