Implement the OS.Time module together with support for blocking the k…

…ernel.

Set the kernel thread stack size to 40 pages to avoid fatal double faults for some larger recursions, e.g. the one in perf/thread_lat.

Improve OS.Main.run along the lines of OS.Time so as the example application.

packages/mirage-platform/_tags

@@ -1,3 +1,3 @@
-<lib/*>: for-pack(OS), use_syntax, use_custom_stdlib
+<lib/*>: for-pack(OS), use_syntax, use_custom_stdlib, use_lwt_syntax
 <syntax/*>: build_syntax
 true: camlp4of

packages/mirage-platform/lib/main.ml

@@ -27,13 +27,23 @@
 
 open Lwt
 
+external block_kernel : int -> unit = "caml_block_kernel"
+
 let run t =
   let rec aux () =
     Lwt.wakeup_paused ();
+    Time.restart_threads Clock.time;
     try
       match Lwt.poll t with
       | Some _ -> true
-      | None   -> false
+      | None   ->
+        let timeout =
+          match Time.select_next Clock.time with
+          | None    -> 86400000000
+          | Some tm -> tm
+        in
+        block_kernel timeout;
+        false
     with exn ->
       (let t   = Printexc.to_string exn in
        let msg = Printf.sprintf "Top-level exception: \"%s\"!" t in

packages/mirage-platform/lib/oS.mlpack

@@ -1,3 +1,4 @@
 Main
 Console
 Clock
+Time

packages/mirage-platform/lib/time.ml

@@ -0,0 +1,105 @@
+(* Lightweight thread library for Objective Caml
+ * http://www.ocsigen.org/lwt
+ * Module Lwt_mirage, based on Lwt_unix
+ * Copyright (C) 2005-2008 Jérôme Vouillon
+ * Laboratoire PPS - CNRS Université Paris Diderot
+ *                    2009 Jérémie Dimino
+ * Copyright (C) 2010 Anil Madhavapeddy
+ * Copyright (C) 2012 Gabor Pali
+ *
+ * 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.
+ *)
+
+open Lwt
+
+type sleep = {
+  time : int;
+  mutable canceled : bool;
+  thread : unit Lwt.u;
+}
+
+module SleepQueue =
+  Lwt_pqueue.Make (struct
+                     type t = sleep
+                     let compare { time = t1 } { time = t2 } = compare t1 t2
+                   end)
+
+let sleep_queue = ref SleepQueue.empty
+
+let new_sleeps = ref []
+
+let sleep d =
+  let (res, w) = Lwt.task () in
+  let t = if d <= 0 then 0 else Clock.time () + d in
+  let sleeper = { time = t; canceled = false; thread = w } in
+  new_sleeps := sleeper :: !new_sleeps;
+  Lwt.on_cancel res (fun _ -> sleeper.canceled <- true);
+  res
+
+let yield () = sleep 0
+
+let auto_yield timeout =
+  let limit = ref (Clock.time () + timeout) in
+  fun () ->
+    let current = Clock.time () in
+    if current >= !limit then begin
+      limit := current + timeout;
+      yield ();
+    end else
+      return ()
+
+exception Timeout
+
+let timeout d = sleep d >> Lwt.fail Timeout
+
+let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()]
+
+let in_the_past now t =
+  t = 0 || t <= now ()
+
+let rec restart_threads now =
+  match SleepQueue.lookup_min !sleep_queue with
+    | Some{ canceled = true } ->
+        sleep_queue := SleepQueue.remove_min !sleep_queue;
+        restart_threads now
+    | Some{ time = time; thread = thread } when in_the_past now time ->
+        sleep_queue := SleepQueue.remove_min !sleep_queue;
+        Lwt.wakeup thread ();
+        restart_threads now
+    | _ -> ()
+
+let min_timeout a b = match a, b with
+  | None, b -> b
+  | a, None -> a
+  | Some a, Some b -> Some(min a b)
+
+let rec get_next_timeout now =
+  match SleepQueue.lookup_min !sleep_queue with
+    | Some{ canceled = true } ->
+        sleep_queue := SleepQueue.remove_min !sleep_queue;
+        get_next_timeout now
+    | Some{ time = time } ->
+        Some (if time = 0 then 0 else max 0 (time - (now ())))
+    | None ->
+        None
+
+let select_next now =
+  sleep_queue :=
+    List.fold_left
+      (fun q e -> SleepQueue.add e q) !sleep_queue !new_sleeps;
+  new_sleeps := [];
+  get_next_timeout now

packages/mirage-platform/lib/time.mli

@@ -0,0 +1,23 @@
+(*
+ * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2012 Gabor Pali
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+val restart_threads: (unit -> int) -> unit
+val select_next : (unit -> int) -> int option
+val sleep : int -> unit Lwt.t
+
+exception Timeout
+val with_timeout : int -> (unit -> 'a Lwt.t) -> 'a Lwt.t

packages/mirage-platform/runtime/kernel/kmod.c

@@ -42,6 +42,10 @@
 
 #include "caml/mlvalues.h"
 #include "caml/callback.h"
+#include "caml/memory.h"
+
+CAMLprim value caml_block_kernel(value v_timeout);
+
 
 static char mir_rtparams[64] = "";
 static int mir_debug = 3;
@@ -103,7 +107,7 @@ mirage_kthread_init(void)
 	error = 0;
 	MIR_DEBUG(1, printf("--> mirage_kthread_init()\n"));
 	error = kthread_add(mirage_kthread_body, NULL, NULL, &mirage_kthread,
-	    RFSTOPPED, 0, "mirage");
+	    RFSTOPPED, 40, "mirage");
 	if (error != 0) {
 		printf("[MIRAGE] Could not create herding kernel thread.\n");
 		goto done;
@@ -197,3 +201,15 @@ static moduledata_t mirage_conf = {
 };
 
 DECLARE_MODULE(mirage, mirage_conf, SI_SUB_KLD, SI_ORDER_ANY);
+
+static int block_timo;
+
+CAMLprim value
+caml_block_kernel(value v_timeout)
+{
+	CAMLparam1(v_timeout);
+	block_timo = Int_val(v_timeout);
+	MIR_DEBUG(2, printf("mirage: Blocking kernel for %d us\n", block_timo));
+	pause("caml_block_kernel", (block_timo / 1000000) * hz);
+	CAMLreturn(Val_unit);
+}

packages/mirage-platform/runtime/ocaml/amd64.S

@@ -61,7 +61,7 @@
 
 #endif
 
-#ifdef __PIC__
+#if defined(__PIC__) && !defined(_KERNEL)
 
 /* Position-independent operations on global variables. */
 

packages/mirage-test/main.ml

@@ -1,17 +1,31 @@
+open Lwt
 open OS.Clock
+open OS.Console
+open OS.Time
+open OS.Main
 
 let rec fib n =
-  Printf.printf "[n = %d]%!" n;
   if n < 2 then 1 else fib (n - 1) + fib (n - 2)
 
 let f () =
-  Printf.printf "Sorry, no in-kernel Mirage today!\n%!";
-  Printf.printf "And there is a second message...\n%!";
-  Printf.printf "Finally a third one.\n%!";
-  Printf.printf "Let's do some Fibonacci!\n%!";
-  ignore (fib 10);
-  Printf.printf "\n%!";
-  true
+  log_s "Sorry, no in-kernel Mirage today!" >>
+  log_s "And there is a second message..." >>
+  log_s "Finally a third one." >>
+  log_s "Go to bed for a second..." >>
+  let t1 = time () in
+  sleep 1000000 >>
+  let t2 = time () in
+  log_s "... and now wake up!" >>
+  let passed = (t2 - t1) / 1000 in
+  let msg = Printf.sprintf "Time passed: %d ms.\n" passed in
+  log_s msg >>
+  log_s "Let's do some Fibonacci!" >>
+  let n = 42 in
+  let msg = Printf.sprintf "fib %d = " n in
+  log_s msg >>
+  let msg = Printf.sprintf "%d" (fib n) in
+  log_s msg >>
+  return ()
 
 let day_of n = match n with
   | 0 -> "Sun"
@@ -25,9 +39,10 @@ let day_of n = match n with
 
 let _ =
   Printf.printf "This message comes somewhere from the body.\n%!";
-  let tm = OS.Clock.gmtime (OS.Clock.time ()) in
+  let tm = gmtime (time ()) in
   Printf.printf
     "Current date and time: %d.%02d.%02d. %s %02d:%02d:%02d. (%d)\n%!"
     (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday (day_of tm.tm_wday)
     tm.tm_hour tm.tm_min tm.tm_sec (tm.tm_yday + 1);
-  Callback.register "OS.Main.run" f
+  Printf.printf "Launch the lwt thread!\n%!";
+  run (f ())

packages/mirage-test/regress/Makefile

@@ -29,6 +29,16 @@ perf/sieve:
 	echo "let _ = OS.Main.run (Sieve.main ())" > main.ml
 	${MAKE} -f Makefile.kmod SRCS=sieve.ml KMOD=mirage-perf-sieve
 
+perf/thread_create:
+	ln -sf perf/thread_create.ml thread_create.ml
+	echo "let _ = OS.Main.run (Thread_create.main ())" > main.ml
+	${MAKE} -f Makefile.kmod SRCS=thread_create.ml KMOD=mirage-perf-thread_create
+
+perf/thread_lat:
+	ln -sf perf/thread_lat.ml thread_lat.ml
+	echo "let _ = OS.Main.run (Thread_lat.main ())" > main.ml
+	${MAKE} -f Makefile.kmod SRCS=thread_lat.ml KMOD=mirage-perf-thread_lat
+
 .PHONY: clean
 
 clean:

packages/mirage-test/regress/perf/thread_create.ml

@@ -0,0 +1,27 @@
+open Printf
+open Lwt
+
+let with_time i fn =
+  let t1 = OS.Clock.time () in
+  fn ();
+  let t2 = OS.Clock.time () in
+  let passed = (t2 - t1) / 1000 in
+  printf "%s %d %d ms\n%!" (Sys.os_type) i passed;
+  ()
+
+let main () =
+  let rec loop_s =
+    function
+    | 0 -> return ()
+    | n -> let _ = OS.Time.sleep 1000 in loop_s (n - 1)
+  in
+
+  for_lwt i = 1 to 20 do
+    let sz = i * 100000 in
+    Gc.compact ();
+    with_time sz (fun () ->
+      let _ = loop_s sz in ()
+    );
+    OS.Time.sleep 10000
+  done >>
+  OS.Time.sleep 1000000

packages/mirage-test/regress/perf/thread_lat.ml

@@ -0,0 +1,65 @@
+open Printf
+open Lwt
+
+(* Create a thread that records the OS time at point of creation,
+ * and at the point it wakes up, and measures the jitter.
+ *)
+let jitter_t t =
+  let duration = (Random.int 2000000) + 1000000 in
+  (* Wait for the passed in thread to wake as a sync point *)
+  lwt () = t in
+  let t1 = OS.Clock.time () in
+  lwt () = OS.Time.sleep duration in
+  let t2 = OS.Clock.time () in
+  return (t2 - t1 - duration)
+
+(* Cumulative distribution function of results list *)
+let maxt = 2000
+let mint = 0
+let diff = maxt - mint
+let buckets = 50
+let quant = diff / buckets
+let b = Array.create (buckets + 1) 0
+
+let cdf res =
+  (* Put each result in a bucket *)
+  List.iter (fun j ->
+    let bucket = ((j - mint) / quant) in
+    let bucket = if bucket >= buckets then
+     ((buckets - 1)) else bucket in
+    b.(bucket) <- b.(bucket) + 1
+  ) res;
+  return ()
+
+let cdf_show () =
+  Array.iteri (fun i x -> printf "%s %d %d %d\n%!" Sys.os_type (mint + (i * quant)) i x) b;
+  return ()
+
+let main () =
+  (* Construction X parallel threads and measure each of their
+   * jitters
+   *)
+  let make_threads num =
+    let t,u = Lwt.task () in
+    let rec loop acc =
+      function
+      |0 -> acc
+      |n ->
+        let th = jitter_t t in
+        loop (th::acc) (n-1)
+    in
+    (loop [] num), u
+  in
+  for_lwt i = 0 to 5 do
+    let reps = 1000 in
+    (* Make threads and launch the parallel map *)
+    let ths, u = make_threads reps in
+    let result_t = Lwt_list.map_p (fun x -> x) ths in
+    (* Settle the GC *)
+    Gc.compact ();
+    (* Launch them! *)
+    Lwt.wakeup u ();
+    lwt results = result_t in
+    cdf results
+  done >>
+  cdf_show ()

packages/myocamlbuild.ml

@@ -14,16 +14,21 @@ module Util = struct
     with Not_found -> !x
 
     let split_nl s = split s '\n'
-    let run_and_read x = List.hd (split_nl (Ocamlbuild_pack.My_unix.run_and_read x))
+    let run_and_read x =
+      match split_nl (Ocamlbuild_pack.My_unix.run_and_read x) with
+      | []     -> ""
+      | (x::_) -> x
 end
 
-let query dir = Util.run_and_read ("ocamlfind query " ^ dir);;
+let query dir = Util.run_and_read ("ocamlfind query " ^ dir ^ " || true");;
 
 dispatch begin function
 | After_rules ->
     flag ["camlp4of"; "build_syntax"]
 	(S[A "-I"; A "+camlp4"]);
     flag ["compile"; "use_custom_stdlib"]
 	(S[A "-nostdlib"; A "-I"; A (query "mirage-stdlib")]);
+    flag ["ocaml"; "pp"; "use_lwt_syntax"]
+	(S[A "-I"; A (query "lwt"); A "lwt-syntax-options.cma"; A "lwt-syntax.cma"]);
 | _ -> ()
 end;;