unikernel/duniverse/eqaf/clock/clock_linux.ml

@@ -0,0 +1,6 @@
+external clock_linux_get_time
+  : unit -> (int64[@unboxed])
+  = "clock_linux_get_time_byte" "clock_linux_get_time_native"
+[@@noalloc]
+
+let now () = clock_linux_get_time ()

unikernel/duniverse/eqaf/clock/clock_linux_stubs.c

@@ -0,0 +1,57 @@
+#define CAML_NAME_SPACE
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+#include <errno.h>
+#include <stdint.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#ifndef __unused
+#define __unused(x) x __attribute((unused))
+#endif
+#define __unit() value __unused(unit)
+
+CAMLprim value
+clock_linux_get_time_byte(__unit ())
+{
+  struct timespec ts;
+
+  if (clock_gettime(CLOCK_MONOTONIC, &ts))
+    caml_invalid_argument("clock: unsupported clock");
+
+  return caml_copy_int64(ts.tv_sec * 1000000000LL + ts.tv_nsec);
+}
+
+// XXX(dinosaure): commented because to be able to compile the test into any
+// platform (ARM)
+//
+// uint64_t
+// clock_linux_get_tick(__unit ())
+// {
+//   // struct timespec ts;
+//   unsigned hi, lo;
+//   __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi));
+// 
+//   // XXX(dinosaure): [clock_gettime] costs a lot and are
+//   // not really precise. [rdtsc] (Read Time Stamp Counter)
+//   // is more reliable.
+// 
+//   return (((unsigned long long) lo) | (((unsigned long long) hi) << 32));
+// }
+
+uint64_t
+clock_linux_get_time_native(__unit ())
+{
+  struct timespec ts;
+
+  (void) clock_gettime(CLOCK_MONOTONIC, &ts);
+  // XXX(dinosaure): assume that it will never fail.
+  // [caml_invalid_argument] allocs.
+
+  return (ts.tv_sec * 1000000000LL + ts.tv_nsec);
+}

unikernel/duniverse/eqaf/clock/clock_mach.ml

@@ -0,0 +1,5 @@
+external clock_mach_init : unit -> unit = "clock_mach_init"
+external clock_mach_get_time : unit -> int64 = "clock_mach_get_time"
+
+let () = clock_mach_init ()
+let now () = clock_mach_get_time ()

unikernel/duniverse/eqaf/clock/clock_mach_stubs.c

@@ -0,0 +1,35 @@
+#ifdef __MACH__
+#include <mach/mach.h>
+#include <mach/mach_time.h>
+#include <unistd.h>
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+// (c) Daniel Bünzli
+
+static mach_timebase_info_data_t s = { 0 };
+
+CAMLprim value
+clock_mach_init(value unit)
+{
+  if (mach_timebase_info (&s) != KERN_SUCCESS)
+    caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info () failed"));
+  if (s.denom == 0)
+    caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info_data.denom is 0"));
+
+  return Val_unit;
+}
+
+CAMLprim value
+clock_mach_get_time(value unit)
+{
+  uint64_t now;
+
+  now = mach_absolute_time();
+
+  return caml_copy_int64(now * s.numer / s.denom);
+}

unikernel/duniverse/eqaf/clock/clock_windows.ml

@@ -0,0 +1,5 @@
+external clock_windows_get_time : unit -> int64 = "clock_windows_get_time"
+external clock_windows_init : unit -> unit = "clock_windows_init"
+
+let () = clock_windows_init ()
+let now () = clock_windows_get_time ()

unikernel/duniverse/eqaf/clock/clock_windows_stubs.c

@@ -0,0 +1,30 @@
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+
+#include <windows.h>
+
+static LARGE_INTEGER frequency;
+
+CAMLprim value
+clock_windows_init(value unit)
+{
+  QueryPerformanceFrequency(&frequency);
+  frequency.QuadPart = 1000000000L / frequency.QuadPart;
+
+  return Val_unit;
+}
+
+CAMLprim value
+clock_windows_get_time(value unit)
+{
+  CAMLparam0();
+  CAMLlocal1(res);
+  LARGE_INTEGER now;
+
+  QueryPerformanceCounter(&now);
+
+  res = caml_copy_int64(now.QuadPart * frequency.QuadPart);
+
+  CAMLreturn(res);
+}

unikernel/duniverse/eqaf/clock/dune

@@ -0,0 +1,21 @@
+(rule
+ (targets clock.ml clock_stubs.c clock.sexp)
+ (deps
+  (:select select/select.ml)
+  clock_linux.ml
+  clock_linux_stubs.c
+  clock_windows.ml
+  clock_windows_stubs.c
+  clock_mach.ml
+  clock_mach_stubs.c)
+ (action
+  (run %{ocaml} %{select} --system %{ocaml-config:system} -o clock)))
+
+(library
+ (name clock)
+ (modules clock)
+ (foreign_stubs
+  (language c)
+  (names clock_stubs)
+  (flags
+   (:include clock.sexp))))

unikernel/duniverse/eqaf/clock/select/select.ml

@@ -0,0 +1,68 @@
+let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt
+
+let load_file filename =
+  let ic = open_in_bin filename in
+  let ln = in_channel_length ic in
+  let rs = Bytes.create ln in
+  let () = really_input ic rs 0 ln in
+  Bytes.unsafe_to_string rs
+
+let sexp_linux = "(-lrt)"
+
+let sexp_freebsd = "()"
+
+let sexp_windows = "()"
+
+let sexp_mach = "()"
+
+let () =
+  let system, output =
+    try
+      match Sys.argv with
+      | [|_; "--system"; system; "-o"; output|] ->
+          let system =
+            match system with
+            | "linux" | "elf" -> `Linux
+            | "win32" | "win64" | "mingw64" | "mingw" | "cygwin" -> `Windows
+            | "freebsd" -> `FreeBSD
+            | "macosx" -> `MacOSX
+            | "beos" | "dragonfly" | "bsd" | "openbsd" | "netbsd" | "gnu"
+            | "solaris" | "unknown" ->
+              invalid_arg "Unsupported system: %s" system
+            | v ->
+              if String.sub system 0 5 = "linux"
+              then `Linux
+              else invalid_arg "Invalid argument of system option: %s" v
+          in
+          (system, output)
+      | _ -> invalid_arg "%s --system system -o <output>" Sys.argv.(0)
+    with _ -> invalid_arg "%s --system system -o <output>" Sys.argv.(0)
+  in
+  let oc_ml, oc_c, oc_sexp =
+    ( open_out (output ^ ".ml")
+    , open_out (output ^ "_stubs.c")
+    , open_out (output ^ ".sexp") )
+  in
+  let ml, c, sexp =
+    match system with
+    | `Linux ->
+        ( load_file "clock_linux.ml"
+        , load_file "clock_linux_stubs.c"
+        , sexp_linux )
+    | `FreeBSD ->
+        ( load_file "clock_linux.ml"
+        , load_file "clock_linux_stubs.c"
+        , sexp_freebsd )
+    | `Windows ->
+        ( load_file "clock_windows.ml"
+        , load_file "clock_windows_stubs.c"
+        , sexp_windows )
+    | `MacOSX ->
+        (load_file "clock_mach.ml", load_file "clock_mach_stubs.c", sexp_mach)
+  in
+  Printf.fprintf oc_ml "%s%!" ml ;
+  Printf.fprintf oc_c "%s%!" c ;
+  Printf.fprintf oc_sexp "%s%!" sexp ;
+  close_out oc_ml ;
+  close_out oc_c ;
+  close_out oc_sexp