Source file `time.ml`

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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
(* Lightweight thread library for Objective Caml
 * http://www.ocsigen.org/lwt
 * Module Lwt_mirage, based on Lwt_unix
 * Copyright (C) 2010 Anil Madhavapeddy
 * Copyright (C) 2005-2008 J�r�me Vouillon
 * Laboratoire PPS - CNRS Universit� Paris Diderot
 *                    2009 J�r�mie Dimino
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as
 * published by the Free Software Foundation, with linking exceptions;
 * either version 2.1 of the License, or (at your option) any later
 * version. See COPYING file for details.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 * 02111-1307, USA.
 *)

external time : unit -> int64 = "caml_get_monotonic_time"

type t = int64

(* +-----------------------------------------------------------------+
   | Sleepers                                                        |
   +-----------------------------------------------------------------+ *)

module SleepQueue = Binary_heap.Make (struct
  type t = Mirage_sleep.t

  let compare Mirage_sleep.{ time = t1; _ } Mirage_sleep.{ time = t2; _ } =
    compare t1 t2
end)

(* Threads waiting for a timeout to expire: *)
let sleep_queue =
  let dummy =
    Mirage_sleep.
      { time = time (); canceled = false; thread = Lwt.wait () |> snd }
  in
  SleepQueue.create ~dummy 0

let in_the_past now t = t = 0L || t <= now ()

let rec restart_threads now =
  match SleepQueue.minimum sleep_queue with
  | exception Binary_heap.Empty -> ()
  | { canceled = true; _ } ->
      SleepQueue.remove sleep_queue;
      restart_threads now
  | { time; thread; _ } when in_the_past now time ->
      SleepQueue.remove sleep_queue;
      Lwt.wakeup thread ();
      restart_threads now
  | _ -> ()

(* +-----------------------------------------------------------------+
   | Event loop                                                      |
   +-----------------------------------------------------------------+ *)

let rec get_next_timeout () =
  match SleepQueue.minimum sleep_queue with
  | exception Binary_heap.Empty -> None
  | { canceled = true; _ } ->
      SleepQueue.remove sleep_queue;
      get_next_timeout ()
  | { time; _ } -> Some time

let select_next () =
  (* Transfer all sleepers added since the last iteration to the main
     sleep queue: *)
  List.iter
    (fun e -> SleepQueue.add sleep_queue e)
    (Mirage_sleep.new_sleepers ());
  get_next_timeout ()