summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Simon Van Casteren <simon.van.casteren@gmail.com>2019-12-15 10:20:47 +0100
committerGravatar Simon Van Casteren <simon.van.casteren@gmail.com>2019-12-15 10:20:47 +0100
commit586ebe1d29c591aa735e3ed9b7bfc1b1407b3d69 (patch)
tree81c5af8095c776c084d0688ba9b9623d9cdfc0fc
parent91d154f3fa8634698faea010c9d965009a76fbcb (diff)
Added background threads
-rw-r--r--src/bg_thread.sig7
-rw-r--r--src/bg_thread.sml67
-rw-r--r--src/lsp.sml111
-rw-r--r--src/sources4
4 files changed, 144 insertions, 45 deletions
diff --git a/src/bg_thread.sig b/src/bg_thread.sig
new file mode 100644
index 00000000..5455bbc8
--- /dev/null
+++ b/src/bg_thread.sig
@@ -0,0 +1,7 @@
+(* Notice: API is kinda bad. We only allow queuing a single task per file *)
+(* This works for us because we only do elaboration in the background, nothing else *)
+signature BGTHREAD = sig
+ val queueBgTask: string (* fileName *) -> (unit -> unit) -> unit
+ val hasBgTasks: unit -> bool
+ val runBgTaskForABit: unit -> unit
+end
diff --git a/src/bg_thread.sml b/src/bg_thread.sml
new file mode 100644
index 00000000..c5eb723c
--- /dev/null
+++ b/src/bg_thread.sml
@@ -0,0 +1,67 @@
+(* Notice: API is kinda bad. We only allow queuing a single task per file *)
+(* This works for us because we only do elaboration in the background, nothing else *)
+
+structure BgThread:> BGTHREAD = struct
+ open Posix.Signal
+ open MLton
+ open Itimer Signal Thread
+
+ val debug = LspSpec.debug
+
+ val topLevel: Thread.Runnable.t option ref = ref NONE
+ val currentRunningThreadIsForFileName: string ref = ref ""
+ (* FIFO queue: Max one task per fileName *)
+ val tasks: ((Thread.Runnable.t * string) list) ref = ref []
+ fun hasBgTasks () = List.length (!tasks) > 0
+
+ fun setItimer t =
+ Itimer.set (Itimer.Real,
+ {value = t,
+ interval = t})
+
+
+ fun done () = Thread.atomically
+ (fn () =>
+ ( tasks := (List.filter (fn q => #2 q <> (!currentRunningThreadIsForFileName)) (!tasks))
+ ; case !tasks of
+ [] => (setItimer Time.zeroTime
+ ; currentRunningThreadIsForFileName := ""
+ ; switch (fn _ => valOf (!topLevel)))
+ | t :: rest => (currentRunningThreadIsForFileName := #2 t
+ ; switch (fn _ => #1 t))))
+
+ fun queueBgTask fileName f =
+ let
+ fun new (f: unit -> unit): Thread.Runnable.t =
+ Thread.prepare
+ (Thread.new (fn () => ((f () handle _ => done ())
+ ; done ())),
+ ())
+ in
+ case List.find (fn t => #2 t = fileName) (!tasks) of
+ NONE => tasks := (new f, fileName) :: (!tasks)
+ | SOME t =>
+ (* Move existing task to front of list *)
+ tasks := t :: List.filter (fn q => #2 q <> fileName) (!tasks)
+ end
+
+ fun replaceInList (l: 'a list) (f: 'a -> bool) (replacement: 'a) =
+ List.map (fn a => if f a then replacement else a ) l
+ fun runBgTaskForABit () =
+ case !(tasks) of
+ [] => ()
+ | t :: rest =>
+ (setHandler (alrm, Handler.handler (fn t => (setItimer Time.zeroTime
+ (* This might some not needed, but other wise you get "Dead thread" error *)
+ ; tasks := replaceInList
+ (!tasks)
+ (fn t => #2 t = (!currentRunningThreadIsForFileName))
+ (t, (!currentRunningThreadIsForFileName))
+ ; currentRunningThreadIsForFileName := ""
+ ; valOf (!topLevel))))
+ ; setItimer (Time.fromMilliseconds 200)
+ ; currentRunningThreadIsForFileName := #2 t
+ ; switch (fn top => (topLevel := SOME (Thread.prepare (top, ())); #1 t)) (* store top level thread and activate BG thread *)
+ ; setItimer Time.zeroTime
+ )
+ end
diff --git a/src/lsp.sml b/src/lsp.sml
index 23b54a28..79b96ef9 100644
--- a/src/lsp.sml
+++ b/src/lsp.sml
@@ -480,7 +480,7 @@ fun findMatchingStringInEnv (env: ElabEnv.env) (str: string): LspSpec.completion
, l2_)
, _))
, l1_)) :: _ =>
- (debug "!!"; getCompletionsFromFields env (name ^ ".") (Substring.string str) fields)
+ getCompletionsFromFields env (name ^ ".") (Substring.string str) fields
| _ => [])
end
| _ =>
@@ -500,13 +500,10 @@ fun handleCompletion (state: state) (p: LspSpec.completionReq) =
let
val pos = #position p
val line = List.nth (Substring.fields (fn c => c = #"\n") (Substring.full (#text s)), #line pos)
- val () = debug ("line" ^ Substring.string line)
val chars = [ (* #".", *) #"(", #")", #"{", #"}", #"[", #"]", #"<", #">", #"-", #"=", #":"
, #" ", #"\n", #"#", #",", #"*", #"\"", #"|", #"&", #"$", #"^", #"+", #";"]
val lineUntilPos = Substring.slice (line, 0, SOME (#character pos))
- val () = debug ("lineUntilPos: \"" ^ Substring.string lineUntilPos ^ "\"")
val searchStr = Substring.string (Substring.taker (fn c => not (List.exists (fn c' => c = c') chars)) lineUntilPos)
- val () = debug ("Looking for completions for: \"" ^ searchStr ^ "\"")
val env = #envBeforeThisModule s
val decls = #decls s
val getInfoRes = GetInfo.getInfo env (Elab.StrConst decls) fileName { line = #line pos + 1
@@ -550,54 +547,78 @@ fun handleDocumentDidChange (state: state) (toclient: LspSpec.toclient) (p: LspS
State.insertText fileName (List.foldl applyContentChange (#text s) (#contentChanges p))
end
+fun runInBackground toclient (fileName: string) (f: unit -> unit): unit =
+ BgThread.queueBgTask
+ fileName
+ ((fn () => (f ()
+ handle LspSpec.LspError (LspSpec.InternalError str) => (#showMessage toclient) str 1
+ | LspSpec.LspError LspSpec.ServerNotInitialized => (#showMessage toclient) "Server not initialized" 1
+ | ex => (#showMessage toclient) (General.exnMessage ex) 1
+ ; (#showMessage toclient) ("Done running BG job for " ^ fileName) 3
+ )))
+
fun handleRequest (requestMessage: LspSpec.message) =
case requestMessage of
LspSpec.Notification n =>
- (LspSpec.matchNotification
- n
- { initialized = fn () => ()
- , textDocument_didOpen =
- fn (p, toclient) => State.withState (fn state =>
- (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p)) ;
- elabFileAndSendDiags state toclient (#uri (#textDocument p))))
- , textDocument_didChange =
- fn (p, toclient) => State.withState (fn state => handleDocumentDidChange state toclient p)
- , textDocument_didSave =
- fn (p, toclient) => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))
- , textDocument_didClose =
- fn (p, toclient) => State.removeFile (#path (#uri (#textDocument p)))
- })
+ LspSpec.matchNotification
+ n
+ { initialized = fn () => ()
+ , textDocument_didOpen =
+ fn (p, toclient) =>
+ (State.insertText (#path (#uri (#textDocument p))) (#text (#textDocument p));
+ runInBackground
+ toclient
+ (#path (#uri (#textDocument p)))
+ (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p)))))
+ , textDocument_didChange =
+ fn (p, toclient) =>
+ State.withState (fn state => handleDocumentDidChange state toclient p)
+ , textDocument_didSave =
+ fn (p, toclient) =>
+ runInBackground
+ toclient
+ (#path (#uri (#textDocument p)))
+ (fn () => State.withState (fn state => elabFileAndSendDiags state toclient (#uri (#textDocument p))))
+ , textDocument_didClose =
+ fn (p, toclient) =>
+ State.removeFile (#path (#uri (#textDocument p)))
+ }
| LspSpec.RequestMessage m =>
(* TODO should error handling here be inside handleMessage? *)
- (LspSpec.matchMessage
- m
- { initialize = fn p =>
- (let val st = initState p
- in
- State.init st;
- LspSpec.Success
- { capabilities =
- { hoverProvider = true
- , completionProvider = SOME { triggerCharacters = ["."]}
- , textDocumentSync = { openClose = true
- , change = 2
- , save = SOME { includeText = false }
- }}
- }
- end)
- , shutdown = fn () => LspSpec.Success ()
- , textDocument_hover = fn toclient => State.withState handleHover
- , textDocument_completion = State.withState handleCompletion
- })
+ LspSpec.matchMessage
+ m
+ { initialize = fn p =>
+ (let val st = initState p
+ in
+ State.init st;
+ LspSpec.Success
+ { capabilities =
+ { hoverProvider = true
+ , completionProvider = SOME { triggerCharacters = ["."]}
+ , textDocumentSync = { openClose = true
+ , change = 2
+ , save = SOME { includeText = false }
+ }}
+ }
+ end)
+ , shutdown = fn () => LspSpec.Success ()
+ , textDocument_hover = fn toclient => State.withState handleHover
+ , textDocument_completion = fn p => State.withState (fn s => handleCompletion s p)
+ }
fun serverLoop () =
- let
- val requestMessage =
- LspSpec.readRequestFromStdIO ()
- handle ex => (debug (General.exnMessage ex) ; raise ex)
- in
- handleRequest requestMessage
- end
+ if not (Option.isSome (TextIO.canInput (TextIO.stdIn, 1))) andalso BgThread.hasBgTasks ()
+ then
+ (* no input waiting -> give control to lower prio thread *)
+ BgThread.runBgTaskForABit ()
+ else
+ let
+ val requestMessage =
+ LspSpec.readRequestFromStdIO ()
+ handle ex => (debug ("Error in reading from stdIn: " ^ General.exnMessage ex) ; raise ex)
+ in
+ handleRequest requestMessage
+ end
fun startServer () = while true do serverLoop ()
end
diff --git a/src/sources b/src/sources
index 74171365..686832cc 100644
--- a/src/sources
+++ b/src/sources
@@ -285,6 +285,10 @@ $(SRC)/fromjson.sml
$(SRC)/lspspec.sml
+$(SML_LIB)/basis/mlton.mlb
+$(SRC)/bg_thread.sig
+$(SRC)/bg_thread.sml
+
$(SRC)/lsp.sig
$(SRC)/lsp.sml