From 586ebe1d29c591aa735e3ed9b7bfc1b1407b3d69 Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Sun, 15 Dec 2019 10:20:47 +0100 Subject: Added background threads --- src/bg_thread.sig | 7 ++++ src/bg_thread.sml | 67 ++++++++++++++++++++++++++++++++ src/lsp.sml | 111 ++++++++++++++++++++++++++++++++---------------------- src/sources | 4 ++ 4 files changed, 144 insertions(+), 45 deletions(-) create mode 100644 src/bg_thread.sig create mode 100644 src/bg_thread.sml 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 -- cgit v1.2.3