From 874e3bc001e64ba058d6632ebe22fbcdac16c00d Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Wed, 8 Jan 2020 12:09:57 +0100 Subject: Add bg_thread.dummy.sml to mock MLton threads in sml/nj --- derivation.nix | 2 +- src/bg_thread.dummy.sml | 9 +++++++ src/bg_thread.mlton.sml | 65 +++++++++++++++++++++++++++++++++++++++++++++++ src/bg_thread.sml | 67 ------------------------------------------------- src/prefix.cm | 2 ++ src/prefix.mlb | 3 +++ src/sources | 4 --- 7 files changed, 80 insertions(+), 72 deletions(-) create mode 100644 src/bg_thread.dummy.sml create mode 100644 src/bg_thread.mlton.sml delete mode 100644 src/bg_thread.sml diff --git a/derivation.nix b/derivation.nix index 19582948..e197372e 100644 --- a/derivation.nix +++ b/derivation.nix @@ -18,7 +18,7 @@ stdenv.mkDerivation rec { # rev = "e52ce9f542f64750941cfd84efdb6d993ee20ff0"; # sha256 = "19ba5n7g1dxy7q9949aakqplchsyzwrrnxv8v604vx5sg7fdfn3b"; # }; - src = nix-gitignore.gitignoreSource [] ./.; + src = ./.; buildInputs = [ openssl mlton mysql.connector-c postgresql sqlite automake autoconf libtool icu.dev openssl.dev]; diff --git a/src/bg_thread.dummy.sml b/src/bg_thread.dummy.sml new file mode 100644 index 00000000..699fa741 --- /dev/null +++ b/src/bg_thread.dummy.sml @@ -0,0 +1,9 @@ +(* + Dummy implementation. Threading is only supported in MLton. + All other implementations just immediately run the background tasks +*) +structure BgThread:> BGTHREAD = struct + fun queueBgTask filename f = f () + fun hasBgTasks () = false + fun runBgTaskForABit () = () +end diff --git a/src/bg_thread.mlton.sml b/src/bg_thread.mlton.sml new file mode 100644 index 00000000..91195940 --- /dev/null +++ b/src/bg_thread.mlton.sml @@ -0,0 +1,65 @@ +(* 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 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/bg_thread.sml b/src/bg_thread.sml deleted file mode 100644 index c5eb723c..00000000 --- a/src/bg_thread.sml +++ /dev/null @@ -1,67 +0,0 @@ -(* 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/prefix.cm b/src/prefix.cm index 2e71d073..eab0bf71 100644 --- a/src/prefix.cm +++ b/src/prefix.cm @@ -4,4 +4,6 @@ $/basis.cm $/smlnj-lib.cm $smlnj/ml-yacc/ml-yacc-lib.cm $/pp-lib.cm +$(SRC)/bg_thread.sig +$(SRC)/bg_thread.dummy.sml diff --git a/src/prefix.mlb b/src/prefix.mlb index 6a510481..13122fcf 100644 --- a/src/prefix.mlb +++ b/src/prefix.mlb @@ -3,5 +3,8 @@ local $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb $(SML_LIB)/smlnj-lib/PP/pp-lib.mlb + $(SML_LIB)/basis/mlton.mlb + $(SRC)/bg_thread.sig + $(SRC)/bg_thread.mlton.sml in diff --git a/src/sources b/src/sources index 686832cc..74171365 100644 --- a/src/sources +++ b/src/sources @@ -285,10 +285,6 @@ $(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