Use clock_gettime etc instead of gettimeofday

myocamlbuild.ml

@@ -132,6 +132,7 @@ let _ = dispatch & function
 
       flag ["ocaml";"link";"is_main"](
         S[A"-linkpkg"; A"src/libcutil.a";
+          A"-cclib"; A"-lrt";
          ]);
 
       flag ["ocaml";"byte";"link"] (S[A"-custom";]);

src/lib/to_string.ml

@@ -17,6 +17,7 @@
 external id : 'a -> 'a = "%identity"
 
 let int i = string_of_int i
+let int64 i = Printf.sprintf "%LdL" i
 let string s = Printf.sprintf "%S" s
 let bool = function
   | true -> "true"

src/libcutil.clib

@@ -2,3 +2,4 @@ arakoon_crc32c.o
 bsd_crc32c.o
 arakoon_limits.o
 tcp_info_stubs.o
+clock_stubs.o

src/node/node_main.ml

@@ -645,7 +645,7 @@ let _main_2 (type s)
                         | Some (m, ls) ->
                            if m = my_name
                               || is_preferred_master m
-                              || (Unix.gettimeofday ()) -. ls > lease_period
+                              || (Mp_clock.get_timestamp ()) -. ls > lease_period
                            then
                              (* no master or the current master is also preferred *)
                              Lwt.return_unit

src/node/store.ml

@@ -132,7 +132,7 @@ struct
   let _master store =
     try
       let m = S.get store __master_key in
-      let ls = Unix.gettimeofday () in
+      let ls = Mp_clock.get_timestamp () in
       Some (m,ls)
     with Not_found ->
       None

src/node/sync_backend.ml

@@ -406,7 +406,7 @@ struct
               match Node_cfg.get_master cfg with
                 | Elected | Preferred _ | Forced _ ->
                   begin
-                    let now = Unix.gettimeofday () in
+                    let now = Mp_clock.get_timestamp () in
                     let diff = now -. ls in
                     if diff < float lease_expiration then
                       (Some m,"inside lease")

src/paxos/master.ml

@@ -55,7 +55,7 @@ let master_consensus (type s) constants {mo;v;n;i; lew} () =
               | None ->
                 inject_lease_expired 0.0
               | Some (m, ls) when m = me ->
-                let diff = (Unix.gettimeofday ()) -. ls in
+                let diff = (Multi_paxos.get_timestamp ()) -. ls in
                 if diff >= float constants.lease_expiration
                 then
                   (* if we get here because a LeaseExpired message is
@@ -68,7 +68,7 @@ let master_consensus (type s) constants {mo;v;n;i; lew} () =
                   inject_lease_expired ls
               | Some (_m, ls) (* when m <> me *) ->
                 (* always insert a lease expired after picking up master role
-                   from another node. do not compare gettimeofday with when the
+                   from another node. do not compare timestamp with when the
                    lease started, as we might have acted earlier than necessary
                    with the lease expiration timeout from the other node *)
                 inject_lease_expired ls in
@@ -97,7 +97,7 @@ let stable_master (type s) constants ((n,new_i, lease_expire_waiters) as current
           if not (is_empty lease_expire_waiters)
           then
             begin
-              if (Unix.gettimeofday () -. ls) > 2.2 *. (float constants.lease_expiration)
+              if (Multi_paxos.get_timestamp () -. ls) > 2.2 *. (float constants.lease_expiration)
               then
                 begin
                   (* nobody is taking over, go to elections *)

src/paxos/mp_clock.ml

@@ -0,0 +1,25 @@
+(*
+ * Copyright (2010-2014) INCUBAID BVBA
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ *     http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ *)
+
+let get_timestamp =
+  let open Clock in
+  match get_clock CLOCK_MONOTONIC_RAW with
+    | None -> failwith "Unknown clock: CLOCK_MONOTONIC_RAW"
+    | Some clk -> fun () ->
+        let ts = get_time clk in
+        Timespec.to_float ts
+
+

src/paxos/multi_paxos.ml

@@ -21,6 +21,7 @@ open MPMessage
 open Messaging
 open Master_type
 
+let get_timestamp = Mp_clock.get_timestamp
 
 let section =
   let s = Logger.Section.make "paxos" in
@@ -46,7 +47,7 @@ let can_promise (type s) (module S : Store.STORE with type t = s) store lease_ex
   match S.who_master store with
     | Some (m, ml) ->
       if (
-        ( (ml +. float lease_expiration) > (Unix.gettimeofday ()) )
+        ( (ml +. float lease_expiration) > (get_timestamp ()) )
         &&
         (String.compare requester m) <> 0
       )
@@ -223,12 +224,12 @@ let start_lease_expiration_thread (type s) ?(immediate_lease_expiration=false) c
       begin
         Logger.debug_f_ "%s: waiting %2.1f seconds for lease to expire"
           constants.me sleep_sec >>= fun () ->
-        let t0 = Unix.gettimeofday () in
+        let t0 = get_timestamp () in
         Lwt_unix.sleep sleep_sec >>= fun () ->
         if id = constants.lease_expiration_id
         then
           begin
-            let t1 = Unix.gettimeofday () in
+            let t1 = get_timestamp () in
             Logger.debug_f_ "%s: lease expired (%2.1f passed, %2.1f intended)=> injecting LeaseExpired event for %f"
               constants.me (t1 -. t0) sleep_sec lease_start >>= fun () ->
             constants.inject_event (LeaseExpired (lease_start)) >>= fun () ->
@@ -260,9 +261,9 @@ let start_election_timeout ?(from_master=false) constants n i =
       begin
         let rec t sleep_sec =
           Logger.debug_f_ "%s: waiting %2.1f seconds for timeout" constants.me sleep_sec >>= fun () ->
-          let t0 = Unix.gettimeofday () in
+          let t0 = get_timestamp () in
           Lwt_unix.sleep sleep_sec >>= fun () ->
-          let t1 = Unix.gettimeofday () in
+          let t1 = get_timestamp () in
           Logger.debug_f_ "%s: timeout (n=%s) should have finished by now (%2.1f passed, intended %2.1f)." constants.me (Sn.string_of n) (t1 -. t0) sleep_sec >>= fun () ->
           match constants.election_timeout with
             | None -> Logger.warning_f_ "%s: scheduled election timeout thread but no timeout configured!" constants.me
@@ -279,7 +280,7 @@ let start_election_timeout ?(from_master=false) constants n i =
         Lwt.ignore_result (t sleep_sec)
       end
     | Some _ -> () in
-  constants.election_timeout <- Some (n, i, Unix.gettimeofday () +. sleep_sec);
+  constants.election_timeout <- Some (n, i, get_timestamp () +. sleep_sec);
   Lwt.return ()
 
 type prepare_repsonse =
@@ -341,7 +342,7 @@ let handle_prepare (type s) constants dest n n' i' =
             begin
               (* Ok, we can make a Promise to the other node, if we want to *)
               let make_promise () =
-                constants.respect_run_master <- Some (dest, Unix.gettimeofday () +. (float constants.lease_expiration) /. 4.0);
+                constants.respect_run_master <- Some (dest, get_timestamp () +. (float constants.lease_expiration) /. 4.0);
                 let lv = constants.get_value nak_max in
                 let reply = Promise(n',nak_max,lv) in
                 Logger.info_f_ "%s: handle_prepare: starting election timer" me >>= fun () ->
@@ -357,7 +358,7 @@ let handle_prepare (type s) constants dest n n' i' =
                 | None ->
                   make_promise ()
                 | Some (other, until) ->
-                  let now = Unix.gettimeofday () in
+                  let now = get_timestamp () in
                   if until < now || dest = other
                   then
                     begin

src/paxos/multi_paxos_fsm.ml

@@ -627,7 +627,7 @@ let paxos_produce buffers constants product_wanted =
   Lwt.catch
     (fun () ->
        Logger.debug_f_ "%s: T:waiting for event (%s)" me wmsg >>= fun () ->
-       let t0 = Unix.gettimeofday () in
+       let t0 = Multi_paxos.get_timestamp () in
 
        let wait_for_buffer = function
          | Client -> Lwt_buffer.wait_for_item buffers.client_buffer
@@ -639,7 +639,7 @@ let paxos_produce buffers constants product_wanted =
                        product_wanted in
        Lwt.pick waiters >>= fun () ->
 
-       let t1 = Unix.gettimeofday () in
+       let t1 = Multi_paxos.get_timestamp () in
        let d = t1 -. t0 in
        Logger.debug_f_ "%s: T:waiting for event took:%f" me d >>= fun () ->
 
@@ -782,7 +782,7 @@ let enter_simple_paxos (type s) ?(stop = ref false) constants buffers current_i
   let other_master = match S.who_master constants.store with
     | None -> false
     | Some (_, ls) ->
-      let diff = (Unix.gettimeofday ()) -. ls in
+      let diff = (Multi_paxos.get_timestamp ()) -. ls in
       diff < float constants.lease_expiration in
   let run start_state =
     Lwt.catch

src/paxos/slave.ml

@@ -28,7 +28,7 @@ let time_for_elections ?invalidate_lease_start_until (type s) constants =
       begin
         let invalidate_lease_start_until = match invalidate_lease_start_until with
           | Some x -> x
-          | None -> Unix.gettimeofday () -. (float constants.lease_expiration) in
+          | None -> Multi_paxos.get_timestamp () -. (float constants.lease_expiration) in
         let lease_start =
           match S.who_master constants.store with
           | None         -> 0.0
@@ -43,7 +43,7 @@ let time_for_elections ?invalidate_lease_start_until (type s) constants =
             | None ->
               return true
             | Some(_, until) ->
-              if Unix.gettimeofday () < until
+              if Multi_paxos.get_timestamp () < until
               then
                 false, "lease expired, but respecting another node running for master"
               else
@@ -287,7 +287,7 @@ let slave_discovered_other_master (type s) constants state () =
       let master_before = S.who_master store in
       let lease_expired = match master_before with
         | None -> true
-        | Some (_, ls) -> ls +. (float_of_int constants.lease_expiration) <= Unix.gettimeofday () in
+        | Some (_, ls) -> ls +. (float_of_int constants.lease_expiration) <= Multi_paxos.get_timestamp () in
       Catchup.catchup
         ~tls_ctx
         ~stop:constants.stop

src/paxos/value.ml

@@ -24,7 +24,7 @@ type t =
 
 let create_client_value (us:Update.t list) (synced:bool) = Vc (us, synced)
 let create_master_value
-      ?(lease_start = Unix.gettimeofday ())
+      ?(lease_start = Mp_clock.get_timestamp ())
       m =
   Vm (m,lease_start)
 
@@ -48,7 +48,7 @@ let clear_self_master_set me = function
 
 let fill_other_master_set me = function
   | Vm (m,_) when m <> me ->
-     let now = Unix.gettimeofday () in
+     let now = Mp_clock.get_timestamp () in
      Vm(m,now)
   | Vc _
   | Vm _ as v -> v

src/system/startup.ml

@@ -161,7 +161,7 @@ let post_failure () =
   let v1 = Value.create_client_value [Update.Set("x","y")] false in
   let tlcs = Hashtbl.create 5 in
   let stores = Hashtbl.create 5 in
-  let now = Unix.gettimeofday () in
+  let now = Multi_paxos.get_timestamp () in
 
   let run_node0 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0;v1] node0 in
   let run_node1 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0;v1] node1 in
@@ -221,7 +221,7 @@ let restart_slaves () =
   let v1 = Value.create_client_value [Update.Set("xxx","xxx")] false in
   let tlcs = Hashtbl.create 5 in
   let stores = Hashtbl.create 5 in
-  let now = Unix.gettimeofday () in
+  let now = Multi_paxos.get_timestamp () in
   let run_node0 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0] node0 in
   let run_node1 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0;v1] node1 in
   (* let run_node2 = _make_run ~stores ~tlcs ~now ~get_cfgs ~updates:[u0;u1] node2 in *)
@@ -280,7 +280,7 @@ let ahead_master_loses_role () =
   let v2 = Value.create_client_value [Update.Set("invalidkey", "shouldnotbepresent")] false in
   let tlcs = Hashtbl.create 5 in
   let stores = Hashtbl.create 5 in
-  let now = Unix.gettimeofday () in
+  let now = Multi_paxos.get_timestamp () in
 
   let t_node0 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0] node0 () in
   let t_node1 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0;v0;v1] node1 () in
@@ -349,7 +349,7 @@ let interrupted_election () =
   let v0 = Value.create_master_value ~lease_start:0. wannabe_master in
   let tlcs = Hashtbl.create 5 in
   let stores = Hashtbl.create 5 in
-  let now = Unix.gettimeofday () in
+  let now = Multi_paxos.get_timestamp () in
   let t_node2 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0] node2 () in
   let t_node3 = _make_run ~stores ~tlcs ~now ~get_cfgs ~values:[v0] node3 () in
   Lwt.ignore_result t_node2;
@@ -412,10 +412,10 @@ let interrupted_election () =
       phase2 () in
 
   Lwt.pick
-    [(let t0 = Unix.gettimeofday () in
+    [(let t0 = Multi_paxos.get_timestamp () in
       phase1 () >>= fun () ->
       phase2 () >>= fun () ->
-      let t1 = Unix.gettimeofday () in
+      let t1 = Multi_paxos.get_timestamp () in
       let delta = t1 -. t0 in
       if (delta > (float lease_period))
       then Lwt.return ()

src/tools/clock.ml

@@ -0,0 +1,81 @@
+(*
+ * Copyright 2014, Incubaid BVBA
+ *
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ *
+ *     http://www.apache.org/licenses/LICENSE-2.0
+ *
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ *)
+
+module Clock : sig
+    type clock = CLOCK_REALTIME
+               | CLOCK_REALTIME_COARSE
+               | CLOCK_MONOTONIC
+               | CLOCK_MONOTONIC_COARSE
+               | CLOCK_MONOTONIC_RAW
+               | CLOCK_BOOTTIME
+               | CLOCK_PROCESS_CPUTIME_ID
+               | CLOCK_THREAD_CPUTIME_ID
+
+    type clock_id
+
+    module Timespec : sig
+        type t = { sec : int64
+                 ; nsec : int64
+                 }
+
+        val to_float : t -> float
+        val to_string : t -> string
+    end
+
+    val get_clock : clock -> clock_id option
+    val get_time : clock_id -> Timespec.t
+    val get_res : clock_id -> Timespec.t
+end = struct
+    type clock = CLOCK_REALTIME
+               | CLOCK_REALTIME_COARSE
+               | CLOCK_MONOTONIC
+               | CLOCK_MONOTONIC_COARSE
+               | CLOCK_MONOTONIC_RAW
+               | CLOCK_BOOTTIME
+               | CLOCK_PROCESS_CPUTIME_ID
+               | CLOCK_THREAD_CPUTIME_ID
+
+    type clock_id = int
+
+    module Timespec = struct
+        type t = { sec : int64
+                 ; nsec : int64
+                 }
+
+        let to_float t = Int64.to_float t.sec +. (Int64.to_float t.nsec /. 1000000000.)
+        let to_string t =
+            let open To_string in
+            record [ "sec", int64 t.sec
+                   ; "nsec", int64 t.nsec
+                   ]
+    end
+
+    external _arakoon_clocks_getclockid : int -> int option = "arakoon_clocks_getclockid"
+    external get_time : clock_id -> Timespec.t = "arakoon_clocks_gettime"
+    external get_res : clock_id -> Timespec.t = "arakoon_clocks_getres"
+
+    let get_clock = function
+      | CLOCK_REALTIME -> _arakoon_clocks_getclockid 1
+      | CLOCK_REALTIME_COARSE -> _arakoon_clocks_getclockid 2
+      | CLOCK_MONOTONIC -> _arakoon_clocks_getclockid 3
+      | CLOCK_MONOTONIC_COARSE -> _arakoon_clocks_getclockid 4
+      | CLOCK_MONOTONIC_RAW -> _arakoon_clocks_getclockid 5
+      | CLOCK_BOOTTIME -> _arakoon_clocks_getclockid 6
+      | CLOCK_PROCESS_CPUTIME_ID -> _arakoon_clocks_getclockid 7
+      | CLOCK_THREAD_CPUTIME_ID -> _arakoon_clocks_getclockid 8
+end
+
+include Clock