summaryrefslogtreecommitdiff
path: root/src/bg_thread.mlton.sml
blob: 91195940e2813069bf1c8183ed45aadb06164563 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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