Commits

ysulsky committed 9da75b2

portability fixes

  • Participants
  • Parent commits 43389a4

Comments (0)

Files changed (18)

File base/core/extended/lib/bench.ml

 open Core.Std
 
+module Int63_arithmetic : sig
+  type t = Int63.t
+  val ( + ) : t -> t -> t
+  val ( - ) : t -> t -> t
+  val ( / ) : t -> t -> t
+  val ( * ) : t -> t -> t
+end = Int63
+
 module Test = struct
   type t =
     { name : string option;
 module Result = struct
   module Stat = struct
     type t = {
-      run_time : int;
-      gc_time : int;
+      run_time : Int63.t;
+      gc_time  : Int63.t;
       sample_size : int;
       compactions : int;
       allocated : int;
     }
 
     let empty = {
-      run_time = 0;
-      gc_time  = 0;
+      run_time = Int63.zero;
+      gc_time  = Int63.zero;
       sample_size = 0;
       compactions = 0;
       allocated = 0;
     }
+
+    let (+) a b = {
+      run_time = Int63_arithmetic.(a.run_time + b.run_time);
+      gc_time  = Int63_arithmetic.(a.gc_time  + b.gc_time);
+      sample_size = a.sample_size + b.sample_size;
+      compactions = a.compactions + b.compactions;
+      allocated   = a.allocated   + b.allocated;
+    }
+
+    let min a b = {
+      run_time  = Int63.min a.run_time    b.run_time;
+      gc_time   = Int63.min a.gc_time     b.gc_time;
+      sample_size = Int.min a.sample_size b.sample_size;
+      compactions = Int.min a.compactions b.compactions;
+      allocated   = Int.min a.allocated   b.allocated;
+    }
+
+    let max a b = {
+      run_time  = Int63.max a.run_time    b.run_time;
+      gc_time   = Int63.max a.gc_time     b.gc_time;
+      sample_size = Int.max a.sample_size b.sample_size;
+      compactions = Int.max a.compactions b.compactions;
+      allocated   = Int.max a.allocated   b.allocated;
+    }
+
   end
-  open Stat
 
   type t = string option * int option * Stat.t array
 
-  let fold arr f init =
-    Array.fold_right arr ~init ~f:(fun r v ->
-      { run_time = f r.run_time v.run_time;
-        gc_time  = f r.gc_time v.gc_time;
-        sample_size = f r.sample_size v.sample_size;
-        compactions = f r.compactions v.compactions;
-        allocated = f r.allocated v.allocated;
-      })
-
   let mean arr =
-    let sum = fold arr (+) empty in
-    { run_time = sum.run_time / Array.length arr;
-      gc_time  = sum.gc_time / Array.length arr;
-      sample_size = sum.sample_size / Array.length arr;
-      compactions = sum.compactions / Array.length arr;
-      allocated = sum.allocated / Array.length arr;
+    let sum = Array.fold arr ~f:Stat.(+) ~init:Stat.empty in
+    let n  = Array.length arr in
+    let nl = Int63.of_int n   in
+    { Stat.
+      run_time = Int63_arithmetic.(sum.Stat.run_time / nl);
+      gc_time  = Int63_arithmetic.(sum.Stat.gc_time / nl);
+      sample_size = sum.Stat.sample_size / n;
+      compactions = sum.Stat.compactions / n;
+      allocated = sum.Stat.allocated / n;
     }
 
-  let min arr = fold arr min arr.(0)
-  let max arr = fold arr max arr.(0)
+  let min arr = Array.fold arr ~f:Stat.min ~init:arr.(0)
+  let max arr = Array.fold arr ~f:Stat.max ~init:arr.(0)
 
-  let sample_size arr = arr.(0).sample_size
+  let sample_size arr = arr.(0).Stat.sample_size
 
   let stdev arr =
     if Array.length arr <= 1 then None else
-    let mean_run = (mean arr).run_time in
+    let mean_run = (mean arr).Stat.run_time in
     let diff_sq x y =
-      let d = (Float.of_int x) -. (Float.of_int y) in
+      let d = (Int63.to_float x) -. (Int63.to_float y) in
       d *. d
     in
-    let squares = Array.map arr ~f:(fun stat -> diff_sq mean_run stat.run_time) in
+    let squares = Array.map arr ~f:(fun stat -> diff_sq mean_run stat.Stat.run_time) in
     let squares_sum = Array.fold squares ~init:0. ~f:(+.) in
     let init_sd = sqrt (squares_sum /. Float.of_int (Array.length arr)) in
     Some (init_sd /. sqrt (Float.of_int (sample_size arr)))
 
-  let compactions_occurred arr = (max arr).compactions > 0
+  let compactions_occurred arr = (max arr).Stat.compactions > 0
 
   let allocated_varied arr =
-    (max arr).allocated <> (min arr).allocated
+    (max arr).Stat.allocated <> (min arr).Stat.allocated
 end
 
 (* printing functions *)
 
-let rec time_string ~time_format n =
-  let auto_format n =
-    if n < 1_000_000 then `Ns
-    else if n < 1_000_000_000 then `Us
-    else if n < 1_000_000_000_000 then `Ms
-    else `S
-  in
-  match time_format with
-  | `Auto -> time_string ~time_format:(auto_format n) n
-  | `Ns -> Int.to_string n ^ " ns"
-  | `Us -> Int.to_string (n / 1000) ^ " us"
-  | `Ms -> Int.to_string (n / 1_000_000) ^ " ms"
-  | `S  -> Int.to_string (n / 1_000_000_000) ^ " s"
+let thousand = Int63.of_int 1_000
+let million  = Int63.of_int 1_000_000
+let billion  = Int63.of_int 1_000_000_000
+let trillion = Int63.of_int64_exn 1_000_000_000_000L
+let time_string =
+  let open Int63_arithmetic in
+  let open Int63.Replace_polymorphic_compare in
+  fun ~time_format n ->
+    let time_format =
+      match time_format with
+      | `Auto when n < million  -> `Ns
+      | `Auto when n < billion  -> `Us
+      | `Auto when n < trillion -> `Ms
+      | `Auto                   -> `S
+      | (`Ns | `Us | `Ms | `S) as fmt -> fmt
+    in
+    match time_format with
+    | `Ns -> Int63.to_string n ^ " ns"
+    | `Us -> Int63.to_string (n / thousand) ^ " us"
+    | `Ms -> Int63.to_string (n / million)  ^ " ms"
+    | `S  -> Int63.to_string (n / billion)  ^ " s"
 ;;
 
 let make_name (name_opt, _size_opt, _results) =
   match size_opt with
   | Some size ->
     if size > 0 then
-      time_string ~time_format ((Result.mean results).Result.Stat.run_time / size)
+      let mean_time = (Result.mean results).Result.Stat.run_time in
+      let size = Int63.of_int size in
+      time_string ~time_format (Int63_arithmetic.(mean_time / size))
     else
       ""
   | None -> ""
     if stdev <. 100. then
       sprintf "%.3G ns" stdev
     else
-      time_string ~time_format (Int.of_float stdev)
+      time_string ~time_format (Int63.of_float stdev)
 ;;
 
 let make_allocated (_name_opt, _size_opt, results) =
 ;;
 
 let make_warn (_name_opt, _size_opt, results) =
+  let open Int63_arithmetic in
+  let open Int63.Replace_polymorphic_compare in
+  let twenty = Int63.of_int 20 in
   let maybe_string s predicate = if predicate then s else "" in
-  let open Result in
-  let mean_run = (mean results).Stat.run_time in
-  let min_run  = (min  results).Stat.run_time in
-  let max_run  = (max  results).Stat.run_time in
-  maybe_string   "m" ((mean_run - min_run) > mean_run / 20)
-  ^ maybe_string "M" ((max_run - mean_run) > mean_run / 20)
-  ^ maybe_string "c" (compactions_occurred results)
-  ^ maybe_string "a" (allocated_varied results)
+  let mean_run = (Result.mean results).Result.Stat.run_time in
+  let min_run  = (Result.min  results).Result.Stat.run_time in
+  let max_run  = (Result.max  results).Result.Stat.run_time in
+  maybe_string   "m" ((mean_run - min_run) > mean_run / twenty)
+  ^ maybe_string "M" ((max_run - mean_run) > mean_run / twenty)
+  ^ maybe_string "c" (Result.compactions_occurred results)
+  ^ maybe_string "a" (Result.allocated_varied results)
 ;;
 
 let print ?(time_format=`Auto) data =
     Gc.full_major ();
   done;
   let e = now () in
-  (e - s) / count
+  Int63_arithmetic.((e - s) / Int63.of_int count)
 
 let find_run_size ~now gettime_cost f =
   let rec loop samples =
     let e = now () in
     (* we need enough samples so that the gettime_cost is < 1% of the cost of the run
        and we also demand that the total run take at least .5 seconds *)
-    if gettime_cost > ((e - s) / 100) || (e - s) < 50 * 1000 * 1000
-    then loop (samples * 2)
+    let open Int63_arithmetic in
+    let open Int63.Replace_polymorphic_compare in
+    if gettime_cost > (e - s) / Int63.of_int 100 || (e - s) < Int63.of_int 50_000_000
+    then loop (Int.( * ) samples 2)
     else (samples, e - s)
   in
   loop 1
   let gc_e = now () in
   let stat_e = Gc.quick_stat () in
   {Result.Stat.
-    run_time = (run_e - run_s - gettime_cost) / sample_size;
-    gc_time  = (gc_e - run_e - full_major_cost) / sample_size;
+    run_time = Int63_arithmetic.((run_e - run_s - gettime_cost) / Int63.of_int sample_size);
+    gc_time  = Int63_arithmetic.((gc_e - run_e - full_major_cost) / Int63.of_int sample_size);
     sample_size;
     compactions = stat_e.Gc.Stat.compactions - stat_s.Gc.Stat.compactions;
     allocated = ((gc_allocated stat_m) - (gc_allocated stat_s) - allocated_cost)
   let f () = () in
   let compute ?(allocated_cost=0) sample_size=
     let result =
-      run_once ~f ~sample_size ~gettime_cost:0 ~full_major_cost:0
+      run_once ~f ~sample_size ~gettime_cost:Int63.zero ~full_major_cost:Int63.zero
         ~allocated_cost ~now
     in
     result.Result.Stat.allocated
   assert (0 = compute ~allocated_cost 100);
   allocated_cost
 
-let bench_basic ~verbosity ~gc_prefs ~no_compactions ~clock ~run_count test =
+let bench_basic =
+  let open Core.Std.Result.Monad_infix in
+  Posix_clock.gettime           >>= fun gettime ->
+  Posix_clock.mean_gettime_cost >>= fun mean_gettime_cost ->
+  Posix_clock.min_interval      >>| fun min_interval ->
+  fun ~verbosity ~gc_prefs ~no_compactions ~clock ~run_count test ->
   let print_high s = match verbosity with
     | `High -> printf s
     | `Low | `Mid -> ifprintf stdout s
     | `Wall -> Posix_clock.Monotonic
     | `Cpu  -> Posix_clock.Process_cpu
   in
-  let now () = Posix_clock.gettime measurement_clock in
+  let now () = gettime measurement_clock in
   if no_compactions then Gc.set { (Gc.get ()) with Gc.Control.max_overhead = 1_000_000 };
   (* calculate how long it takes us to get a time measurement for the current thread *)
   print_high "calculating cost of timing measurement: %!";
   let gettime_cost =
-    Posix_clock.mean_gettime_cost ~measure:measurement_clock ~using:Posix_clock.Monotonic
+    mean_gettime_cost ~measure:measurement_clock ~using:Posix_clock.Monotonic
   in
-  print_high "%i ns\n%!" gettime_cost;
+  print_high "%s ns\n%!" (Int63.to_string gettime_cost);
   print_high "calculating minimal measurable interval: %!";
-  let gettime_min_interval = Posix_clock.min_interval measurement_clock in
-  print_high "%i ns\n%!" gettime_min_interval;
+  let gettime_min_interval = min_interval measurement_clock in
+  print_high "%s ns\n%!" (Int63.to_string gettime_min_interval);
   (* find the number of samples of f needed before gettime cost is < 1% of the total *)
   print_high "determining number of runs per sample: %!";
   let sample_size, run_time = find_run_size ~now gettime_min_interval test.Test.f in
   print_high "done\n%!";
   print_high "calculating the cost of a full major sweep: %!";
   let full_major_cost = full_major_cost ~now () in
-  print_high "%i ns\n%!" full_major_cost;
+  print_high "%s ns\n%!" (Int63.to_string full_major_cost);
   print_high "calculating memory allocated by tester: %!";
   let allocated_cost = allocated_cost ~now () in
   print_high "%i words\n%!" allocated_cost;
-  print_mid "running samples for %s (estimated time %i sec)\n%!"
+  print_mid "running samples for %s (estimated time %s sec)\n%!"
     (Option.value ~default:"(NO NAME)" test.Test.name)
-    ((run_time * run_count) / 1000 / 1000 / 1000);
+    (Int63.to_string (Int63_arithmetic.((run_time * Int63.of_int run_count) / billion)));
   for i = 0 to run_count - 1 do
     runs.(i) <- run_once ~f:test.Test.f ~sample_size ~gettime_cost ~full_major_cost ~allocated_cost
       ~now;
 
 let default_run_count = 100
 
-let bench_raw ?(verbosity=`Low) ?gc_prefs ?(no_compactions=false) ?(fast=false)
-    ?(clock=`Wall) tests =
-  let run_count = if fast then 1 else default_run_count in
-  List.map tests ~f:(fun test -> test.Test.name, test.Test.size,
-    bench_basic ~verbosity ~gc_prefs ~no_compactions ?clock ~run_count test)
+let bench_raw =
+  let open Core.Std.Result.Monad_infix in
+  bench_basic >>| fun bench_basic ->
+  fun ?(verbosity=`Low) ?gc_prefs ?(no_compactions=false)
+      ?(fast=false) ?(clock=`Wall) tests ->
+    let run_count = if fast then 1 else default_run_count in
+    List.map tests ~f:(fun test -> test.Test.name, test.Test.size,
+      bench_basic ~verbosity ~gc_prefs ~no_compactions ?clock ~run_count test)
 ;;
 
-let bench ?time_format ?verbosity ?gc_prefs ?no_compactions ?fast ?clock tests =
-  print ?time_format (bench_raw ?verbosity ?gc_prefs ?no_compactions ?fast ?clock tests)
+let bench =
+  let open Core.Std.Result.Monad_infix in
+  bench_raw >>| fun bench_raw ->
+  fun ?time_format ?verbosity ?gc_prefs ?no_compactions ?fast ?clock tests ->
+    print ?time_format (bench_raw ?verbosity ?gc_prefs ?no_compactions ?fast ?clock tests)
 ;;
-
-module Bundle = struct
-  type 'a t =
-    Base of 'a
-  | App of Test.t list * (unit -> 'a) * 'a
-
-  let create init = Base init
-
-  let (>>|) bundle f =
-    match bundle with
-    | Base init -> App
-      ( [Test.create ~name:"#1" (fun () -> ignore (f init))],
-        (fun () -> f init),
-        f init
-      )
-    | App (separate, composed, init) -> App
-      ( (Test.create ~name:(sprintf "#%d" (List.length separate + 1))
-          (fun () -> ignore (f init))) :: separate,
-        (fun () -> f (composed ())),
-        f init
-      )
-
-  (* this does not account for the time spent applying thunks to () but should *)
-  let bench bundle =
-    match bundle with
-    | Base _ -> printf "Bundle is fully evaluated."
-    | App (separate, composed, _) ->
-      let composed_test = Test.create ~name:"Composed" (Fn.compose ignore composed) in
-      bench (composed_test :: separate)
-end

File base/core/extended/lib/bench.mli

 open Core.Std
 
-
 module Test : sig
   type t
   val create : ?name:string -> ?size:int -> (unit -> unit) -> t
 module Result : sig
   module Stat : sig
     type t = {
-      run_time : int;
-      gc_time : int;
+      run_time    : Int63.t;
+      gc_time     : Int63.t;
       sample_size : int;
       compactions : int;
-      allocated : int;
+      allocated   : int;
     }
 
     val empty : t
   ?time_format:[`Ns | `Ms | `Us | `S | `Auto]
   -> 'a
 
-val bench : (Test.t list -> unit) with_benchmark_flags with_print_flags
+val bench : (Test.t list -> unit) with_benchmark_flags with_print_flags Or_error.t
 
 (* Returns a list documenting the runtimes rather than printing to stdout. These can be
    fed to print for results identical to calling bench. *)
-val bench_raw : (Test.t list -> Result.t list) with_benchmark_flags
+val bench_raw : (Test.t list -> Result.t list) with_benchmark_flags Or_error.t
 
 val print : (Result.t list -> unit) with_print_flags
-
-module Bundle : sig
-  type 'a t
-
-  val create : 'a -> 'a t
-  val (>>|) : 'a t -> ('a -> 'b) -> 'b t
-  val bench : 'a t -> unit
-end

File base/core/extended/lib/extended_linux.ml

-(*pp camlp4o -I `ocamlfind query sexplib` -I `ocamlfind query type-conv` -I `ocamlfind query bin_prot` pa_type_conv.cmo pa_sexp_conv.cmo pa_bin_prot.cmo *)
+open Core.Std
 
-open Core.Std
-open Unix
-
-external setresuid : ruid:int -> euid:int -> suid:int -> unit = "linux_setresuid_stub"
-
-let setresuid ?(ruid= -1) ?(euid= -1) ?(suid= -1) () =
-  setresuid ~ruid ~euid ~suid
+INCLUDE "config.mlh"
 
 type uids = {
   ruid:int;
   suid:int
 } with sexp,bin_io
 
+module Statfs = struct
+  module Raw = struct
+    type t =
+      {
+        f_type    : Int32.t;
+        f_bsize   : int;
+        f_blocks  : int;
+        f_bfree   : int;
+        f_bavail  : int;
+        f_files   : int;
+        f_ffree   : int;
+        f_namelen : int;
+      }
+    ;;
+  end
+  type f_type =
+        ADFS_SUPER_MAGIC | AFFS_SUPER_MAGIC | BEFS_SUPER_MAGIC | BFS_MAGIC
+      | CIFS_MAGIC_NUMBER | CODA_SUPER_MAGIC | COH_SUPER_MAGIC | CRAMFS_MAGIC
+      | DEVFS_SUPER_MAGIC | EFS_SUPER_MAGIC | EXT_SUPER_MAGIC | EXT2_OLD_SUPER_MAGIC
+      | EXT2_SUPER_MAGIC | EXT3_SUPER_MAGIC | HFS_SUPER_MAGIC | HPFS_SUPER_MAGIC
+      | HUGETLBFS_MAGIC | ISOFS_SUPER_MAGIC | JFFS2_SUPER_MAGIC | JFS_SUPER_MAGIC
+      | MINIX_SUPER_MAGIC | MINIX_SUPER_MAGIC2 | MINIX2_SUPER_MAGIC | MINIX2_SUPER_MAGIC2
+      | MSDOS_SUPER_MAGIC | NCP_SUPER_MAGIC | NFS_SUPER_MAGIC | NTFS_SB_MAGIC
+      | UNKNOWN_SUPER_MAGIC of Int32.t
+  ;;
+  type t =
+    {
+      f_type    : f_type;
+      f_bsize   : int;
+      f_blocks  : int;
+      f_bfree   : int;
+      f_bavail  : int;
+      f_files   : int;
+      f_ffree   : int;
+      f_namelen : int;
+    }
+  ;;
+  let of_rawstatfs raw =
+    {
+      f_type =
+         begin match raw.Raw.f_type with
+         | 0xadf5l     -> ADFS_SUPER_MAGIC
+         | 0xADFFl     -> AFFS_SUPER_MAGIC
+         | 0x42465331l -> BEFS_SUPER_MAGIC
+         | 0x1BADFACEl -> BFS_MAGIC
+         | 0xFF534D42l -> CIFS_MAGIC_NUMBER
+         | 0x73757245l -> CODA_SUPER_MAGIC
+         | 0x012FF7B7l -> COH_SUPER_MAGIC
+         | 0x28cd3d45l -> CRAMFS_MAGIC
+         | 0x1373l     -> DEVFS_SUPER_MAGIC
+         | 0x00414A53l -> EFS_SUPER_MAGIC
+         | 0x137Dl     -> EXT_SUPER_MAGIC
+         | 0xEF51l     -> EXT2_OLD_SUPER_MAGIC
+         | 0xEF53l     -> EXT2_SUPER_MAGIC
+(*       | 0xEF53l     -> EXT3_SUPER_MAGIC *)
+         | 0x4244l     -> HFS_SUPER_MAGIC
+         | 0xF995E849l -> HPFS_SUPER_MAGIC
+         | 0x958458f6l -> HUGETLBFS_MAGIC
+         | 0x9660l     -> ISOFS_SUPER_MAGIC
+         | 0x72b6l     -> JFFS2_SUPER_MAGIC
+         | 0x3153464al -> JFS_SUPER_MAGIC
+         | 0x137Fl     -> MINIX_SUPER_MAGIC
+         | 0x138Fl     -> MINIX_SUPER_MAGIC2
+         | 0x2468l     -> MINIX2_SUPER_MAGIC
+         | 0x2478l     -> MINIX2_SUPER_MAGIC2
+         | 0x4d44l     -> MSDOS_SUPER_MAGIC
+         | 0x564cl     -> NCP_SUPER_MAGIC
+         | 0x6969l     -> NFS_SUPER_MAGIC
+         | 0x5346544el -> NTFS_SB_MAGIC
+         | magic       -> UNKNOWN_SUPER_MAGIC magic
+         end;
+      f_bsize   = raw.Raw.f_bsize;
+      f_blocks  = raw.Raw.f_blocks;
+      f_bfree   = raw.Raw.f_bfree;
+      f_bavail  = raw.Raw.f_bavail;
+      f_files   = raw.Raw.f_files;
+      f_ffree   = raw.Raw.f_ffree;
+      f_namelen = raw.Raw.f_namelen
+    }
+  ;;
+end ;;
+
+IFDEF LINUX_EXT THEN
+
+external setresuid : ruid:int -> euid:int -> suid:int -> unit = "linux_setresuid_stub"
+
+let setresuid ?(ruid= -1) ?(euid= -1) ?(suid= -1) () =
+  setresuid ~ruid ~euid ~suid
+
 external getresuid : unit -> uids = "linux_getresuid_stub"
 
+let setresuid = Ok setresuid
+let getresuid = Ok getresuid
 
 (* Splicing - zero-copies between kernel buffers *)
 
+open Unix
 
 module Splice = struct
   type flag = MOVE | NONBLOCK | MORE | GIFT with sexp, bin_io
   type flags
 
-  external make_flags : flag array -> flags = "linux_splice_make_flags_stub"
-
   external unsafe_splice :
     bool ->
     fd_in : File_descr.t -> off_in : int ->
           count
     in
     unsafe_vmsplice assume_fd_is_nonblocking fd count flags
+
+  external make_flags : flag array -> flags = "linux_splice_make_flags_stub"
+  let splice   = Ok splice
+  let tee      = Ok tee
+  let vmsplice = Ok vmsplice
 end
 
-module Statfs = struct
-  module Raw = struct
-    type t =
-      {
-        f_type    : int;
-        f_bsize   : int;
-        f_blocks  : int;
-        f_bfree   : int;
-        f_bavail  : int;
-        f_files   : int;
-        f_ffree   : int;
-        f_namelen : int;
-      }
-    ;;
-  end
-  type f_type =
-        ADFS_SUPER_MAGIC | AFFS_SUPER_MAGIC | BEFS_SUPER_MAGIC | BFS_MAGIC
-      | CIFS_MAGIC_NUMBER | CODA_SUPER_MAGIC | COH_SUPER_MAGIC | CRAMFS_MAGIC
-      | DEVFS_SUPER_MAGIC | EFS_SUPER_MAGIC | EXT_SUPER_MAGIC | EXT2_OLD_SUPER_MAGIC
-      | EXT2_SUPER_MAGIC | EXT3_SUPER_MAGIC | HFS_SUPER_MAGIC | HPFS_SUPER_MAGIC
-      | HUGETLBFS_MAGIC | ISOFS_SUPER_MAGIC | JFFS2_SUPER_MAGIC | JFS_SUPER_MAGIC
-      | MINIX_SUPER_MAGIC | MINIX_SUPER_MAGIC2 | MINIX2_SUPER_MAGIC | MINIX2_SUPER_MAGIC2
-      | MSDOS_SUPER_MAGIC | NCP_SUPER_MAGIC | NFS_SUPER_MAGIC | NTFS_SB_MAGIC
-      | UNKNOWN_SUPER_MAGIC of int
-  ;;
-  type t =
-    {
-      f_type    : f_type;
-      f_bsize   : int;
-      f_blocks  : int;
-      f_bfree   : int;
-      f_bavail  : int;
-      f_files   : int;
-      f_ffree   : int;
-      f_namelen : int;
-    }
-  ;;
-  let of_rawstatfs raw =
-    {
-      f_type =
-         begin match raw.Raw.f_type with
-         | 0xadf5     -> ADFS_SUPER_MAGIC
-         | 0xADFF     -> AFFS_SUPER_MAGIC
-         | 0x42465331 -> BEFS_SUPER_MAGIC
-         | 0x1BADFACE -> BFS_MAGIC
-         | 0xFF534D42 -> CIFS_MAGIC_NUMBER
-         | 0x73757245 -> CODA_SUPER_MAGIC
-         | 0x012FF7B7 -> COH_SUPER_MAGIC
-         | 0x28cd3d45 -> CRAMFS_MAGIC
-         | 0x1373     -> DEVFS_SUPER_MAGIC
-         | 0x00414A53 -> EFS_SUPER_MAGIC
-         | 0x137D     -> EXT_SUPER_MAGIC
-         | 0xEF51     -> EXT2_OLD_SUPER_MAGIC
-         | 0xEF53     -> EXT2_SUPER_MAGIC
-(*       | 0xEF53     -> EXT3_SUPER_MAGIC *)
-         | 0x4244     -> HFS_SUPER_MAGIC
-         | 0xF995E849 -> HPFS_SUPER_MAGIC
-         | 0x958458f6 -> HUGETLBFS_MAGIC
-         | 0x9660     -> ISOFS_SUPER_MAGIC
-         | 0x72b6     -> JFFS2_SUPER_MAGIC
-         | 0x3153464a -> JFS_SUPER_MAGIC
-         | 0x137F     -> MINIX_SUPER_MAGIC
-         | 0x138F     -> MINIX_SUPER_MAGIC2
-         | 0x2468     -> MINIX2_SUPER_MAGIC
-         | 0x2478     -> MINIX2_SUPER_MAGIC2
-         | 0x4d44     -> MSDOS_SUPER_MAGIC
-         | 0x564c     -> NCP_SUPER_MAGIC
-         | 0x6969     -> NFS_SUPER_MAGIC
-         | 0x5346544e -> NTFS_SB_MAGIC
-         | magic      -> UNKNOWN_SUPER_MAGIC magic
-         end;
-      f_bsize   = raw.Raw.f_bsize;
-      f_blocks  = raw.Raw.f_blocks;
-      f_bfree   = raw.Raw.f_bfree;
-      f_bavail  = raw.Raw.f_bavail;
-      f_files   = raw.Raw.f_files;
-      f_ffree   = raw.Raw.f_ffree;
-      f_namelen = raw.Raw.f_namelen
-    }
-  ;;
-  external linux_statfs_stub : string -> Raw.t = "linux_statfs_stub" ;;
-end ;;
+external linux_statfs_stub : string -> Statfs.Raw.t = "linux_statfs_stub" ;;
+let statfs path = Statfs.of_rawstatfs (linux_statfs_stub path) ;;
+let statfs = Ok statfs
 
-let statfs path = Statfs.of_rawstatfs (Statfs.linux_statfs_stub path) ;;
+ELSE
+
+let setresuid = unimplemented "Extended_linux.setresuid"
+let getresuid = unimplemented "Extended_linux.getresuid"
+
+module Splice = struct
+  type flag = MOVE | NONBLOCK | MORE | GIFT with sexp, bin_io
+  type flags = flag array
+
+  let make_flags = Fn.id
+  let splice   = unimplemented "Extended_linux.Splice.splice"
+  let tee      = unimplemented "Extended_linux.Splice.tee"
+  let vmsplice = unimplemented "Extended_linux.Splice.vmsplice"
+end
+
+let statfs = unimplemented "Extended_linux.statfs"
+
+ENDIF

File base/core/extended/lib/extended_linux.mli

   suid:int
 } with sexp,bin_io
 
-val setresuid : ?ruid:int -> ?euid:int -> ?suid:int -> unit -> unit
-val getresuid : unit -> uids
+val setresuid : (?ruid:int -> ?euid:int -> ?suid:int -> unit -> unit) Or_error.t
+val getresuid : (unit -> uids) Or_error.t
 
 (** {6 Splicing - zero-copies between kernel buffers} *)
 
   (** {6 Splice functions} *)
 
   val splice :
-    ?assume_fd_is_nonblocking : bool ->
-    fd_in : File_descr.t -> ?off_in : int ->
-    fd_out : File_descr.t -> ?off_out : int ->
-    len : int ->
-    flags
-    -> int * int * int
+    (?assume_fd_is_nonblocking : bool ->
+     fd_in : File_descr.t -> ?off_in : int ->
+     fd_out : File_descr.t -> ?off_out : int ->
+     len : int ->
+     flags
+     -> int * int * int)
+    Or_error.t
   (** [splice ?assume_fd_is_nonblocking ~fd_in ?off_in ~fd_out ?off_out
       ~len flags] see man-page for details.  @return the triple [(ret,
       ret_off_in, ret_off_out)], where [ret] corresponds to the return
   *)
 
   val tee :
-    ?assume_fd_is_nonblocking : bool ->
-    fd_in : File_descr.t -> fd_out : File_descr.t -> int -> flags -> int
+    (?assume_fd_is_nonblocking : bool ->
+     fd_in : File_descr.t -> fd_out : File_descr.t -> int -> flags -> int)
+    Or_error.t
   (** [tee ?assume_fd_is_nonblocking ~fd_in ~fd_out len flags] see man-page
       for details.
 
   *)
 
   val vmsplice :
-    ?assume_fd_is_nonblocking : bool ->
-    File_descr.t -> Bigstring.t IOVec.t array -> ?count : int -> flags -> int
+    (?assume_fd_is_nonblocking : bool ->
+     File_descr.t -> Bigstring.t IOVec.t array -> ?count : int -> flags -> int)
+    Or_error.t
   (** [vmsplice ?assume_fd_is_nonblocking fd iovecs ?count flags]
       see man-page for details.
 
       | HUGETLBFS_MAGIC | ISOFS_SUPER_MAGIC | JFFS2_SUPER_MAGIC | JFS_SUPER_MAGIC
       | MINIX_SUPER_MAGIC | MINIX_SUPER_MAGIC2 | MINIX2_SUPER_MAGIC | MINIX2_SUPER_MAGIC2
       | MSDOS_SUPER_MAGIC | NCP_SUPER_MAGIC | NFS_SUPER_MAGIC | NTFS_SB_MAGIC
-      | UNKNOWN_SUPER_MAGIC of int
+      | UNKNOWN_SUPER_MAGIC of Int32.t
   ;;
   type t =
     {
   ;;
 end
 
-val statfs : string -> Statfs.t
+val statfs : (string -> Statfs.t) Or_error.t

File base/core/extended/lib/extended_linux_stubs.c

+#include "config.h"
+
+#ifdef JSC_LINUX_EXT
+
 #define _GNU_SOURCE
 
 #include <string.h>
     uerror("statfs", Nothing);
 
   res = caml_alloc_tuple(8);
-  Store_field(res, 0, Val_long(sfs.f_type));
+  Store_field(res, 0, caml_copy_int32(sfs.f_type));
   Store_field(res, 1, Val_long(sfs.f_bsize));
   Store_field(res, 2, Val_long(sfs.f_blocks));
   Store_field(res, 3, Val_long(sfs.f_bfree));
   Store_field(res, 7, Val_long(sfs.f_namelen));
   CAMLreturn(res);
 }
+
+#endif /* JSC_LINUX_EXT */

File base/core/extended/lib/jane_common.h

+#ifndef JANE_COMMON_H
+#define JANE_COMMON_H
+
+#if __GNUC__ >= 3
+# ifndef inline
+#   define inline inline __attribute__ ((always_inline))
+# endif
+# ifndef __pure
+#   define __pure __attribute__ ((pure))
+# endif
+# ifndef __const
+#   define __const __attribute__ ((const))
+# endif
+# ifndef __malloc
+#   define __malloc __attribute__ ((malloc))
+# endif
+# ifndef __unused
+#   define __unused __attribute__ ((unused))
+# endif
+# ifndef __likely
+#   define likely(x) __builtin_expect (!!(x), 1)
+# endif
+# ifndef __unlikely
+#   define unlikely(x) __builtin_expect (!!(x), 0)
+# endif
+#else
+# ifndef inline
+#   define inline
+# endif
+# ifndef __pure
+#   define __pure
+# endif
+# ifndef  __const
+#   define __const
+# endif
+# ifndef  __malloc
+#   define __malloc
+# endif
+# ifndef  __unused
+#   define __unused
+# endif
+# ifndef  __likely
+#   define likely(x) (x)
+# endif
+# ifndef  __unlikely
+#   define unlikely(x) (x)
+# endif
+#endif
+
+#endif /* JANE_COMMON_H */

File base/core/extended/lib/malloc.ml

-(*pp camlp4o -I `ocamlfind query sexplib` -I `ocamlfind query type-conv` -I `ocamlfind query bin_prot` pa_type_conv.cmo pa_sexp_conv.cmo pa_bin_prot.cmo *)
-open Sexplib.Std
-open Bin_prot.Std
+open Core.Std
+
+INCLUDE "config.mlh"
 
 type mallinfo = {
   arena : int;
   keepcost : int;
 } with sexp, bin_io
 
-external mallinfo : unit -> mallinfo = "malloc_mallinfo_stub"
-
 type opt =
   | TRIM_THRESHOLD
   | TOP_PAD
 (*   | PERTURB *)
 with sexp, bin_io
 
-external mallopt : opt -> int -> unit = "malloc_mallopt_stub"
+IFDEF LINUX_EXT THEN
 
-external malloc_trim : int -> unit = "malloc_trim_stub"
+external mallinfo     : unit -> mallinfo   = "malloc_mallinfo_stub"
+external mallopt      : opt -> int -> unit = "malloc_mallopt_stub"
+external malloc_trim  : int -> unit        = "malloc_trim_stub"
+external malloc_stats : unit -> unit       = "malloc_stats_stub"
 
-external malloc_stats : unit -> unit = "malloc_stats_stub"
+let mallinfo     = Ok mallinfo
+let mallopt      = Ok mallopt
+let malloc_trim  = Ok malloc_trim
+let malloc_stats = Ok malloc_stats
+
+ELSE
+
+let mallinfo     = unimplemented "Malloc.mallinfo"
+let mallopt      = unimplemented "Malloc.mallopt"
+let malloc_trim  = unimplemented "Malloc.malloc_trim"
+let malloc_stats = unimplemented "Malloc.malloc_stats"
+
+ENDIF

File base/core/extended/lib/malloc.mli

+open Core.Std
+
 (** Malloc bindings
 
-    Allows you to set/query the behaviour of malloc.
+    Allows you to set/query the behaviour of malloc. The functions in this
+    module may not be implemented on your platform.
 *)
 
 type mallinfo = {
   keepcost : int;  (** top-most, releasable (via malloc_trim) space *)
 } with sexp, bin_io
 
-(** [mallinfo ()] @return information on the state of malloced memory
-    (C-heap). *)
-external mallinfo : unit -> mallinfo = "malloc_mallinfo_stub"
-
 (** Malloc options *)
 type opt =
   | TRIM_THRESHOLD  (** Maximum amount of unused top-most memory to keep
 (*   | PERTURB  (** ??? *) *)
 with sexp, bin_io
 
+(** [mallinfo ()]
+    @return information on the state of malloced memory (C-heap). *)
+val mallinfo : (unit -> mallinfo) Or_error.t
+
 (** [mallopt opt n] sets malloc configuration option [opt] to [n]. *)
-external mallopt : opt -> int -> unit = "malloc_mallopt_stub"
+val mallopt : (opt -> int -> unit) Or_error.t
 
 (** [malloc_trim n] release all but [n] bytes of freed top-most memory
     back to the system.
 
     @raise Failure if unsuccessful.
 *)
-external malloc_trim : int -> unit = "malloc_trim_stub"
+val malloc_trim : (int -> unit) Or_error.t
 
 (** [malloc_stats ()] prints brief summary statistics on stderr. *)
-external malloc_stats : unit -> unit = "malloc_stats_stub"
+val malloc_stats : (unit -> unit) Or_error.t

File base/core/extended/lib/malloc_stubs.c

+#include "config.h"
+
+#ifdef JSC_LINUX_EXT
+
 #include <malloc.h>
 #include "ocaml_utils.h"
 
   caml_leave_blocking_section();
   return Val_unit;
 }
+
+#endif /* JSC_LINUX_EXT */

File base/core/extended/lib/ocaml_utils.h

+#ifndef OCAML_UTILS_H
+#define OCAML_UTILS_H
+
+#include "jane_common.h"
+
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/signals.h>
+#include <caml/bigarray.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+
+#define Nothing ((value) 0)
+#define XSTR(S) STR(S)
+#define STR(S) #S
+
+/* [strcmp] is defined as a macro in our current compilation environment.  We use
+   [strcmp_not_a_macro] instead so that the text of this macro does not overflow the
+   C89 limit on string literal length when used inside [assert]. */
+
+/* defined in ocaml_utils_stubs.c */
+extern int strcmp_not_a_macro(const char*, const char*);
+
+extern void unix_error (int errcode, char *cmdname, value arg) Noreturn;
+extern value unix_error_of_code(int errcode);
+extern void uerror (char *cmdname, value arg) Noreturn;
+
+extern value getsockopt_int(int *tcpopt, value sock, int level, value option);
+
+extern value setsockopt_int(
+  int *tcpopt, value sock, int level, value option, value status);
+
+extern int caml_convert_signal_number(int signo);
+extern int caml_rev_convert_signal_number(int signo);
+
+extern void raise_with_two_args(value tag, value arg1, value arg2) Noreturn;
+
+extern value* named_value_exn(const char* n);
+extern void raise_out_of_memory(void);
+extern void* malloc_exn(size_t size);
+
+extern const char* string_ocaml_to_c(value s_v);
+extern const char* string_of_ocaml_string_option(value v);
+extern int int_of_ocaml_int_option(value v, int* i);
+
+extern const char** array_map(value array, const char* (*f__must_not_allocate)(value));
+
+#endif /* OCAML_UTILS_H */

File base/core/extended/lib/posix_clock.ml

+open Core.Std
+
+INCLUDE "config.mlh"
+
 type t =
   | Realtime
   | Monotonic
   | Process_cpu    -> "Process_cpu"
   | Process_thread -> "Process_thread"
 
-external getres : t -> int = "caml_clock_getres"
-external gettime : t -> int = "caml_clock_gettime"
+IFDEF POSIX_TIMERS THEN
+
+external getres : t -> Int63.t = "caml_clock_getres"
+external gettime : t -> Int63.t = "caml_clock_gettime"
 (*external nanosleep : t -> int -> unit = "caml_clock_nanosleep"*)
 
+module Int63_arithmetic : sig
+  type t = Int63.t
+  val ( + ) : t -> t -> t
+  val ( - ) : t -> t -> t
+  val ( / ) : t -> t -> t
+  val ( * ) : t -> t -> t
+end = Int63
+
 let min_interval t =
-  let canary_val = 1_000_000 in
+  let canary_val = Int63.of_int 1_000_000 in
   let current_min = ref canary_val in
   for i = 1 to 10_000 do
     let t1 = gettime t in
     let t2 = gettime t in
+    let open Int63.Replace_polymorphic_compare in
+    let open Int63_arithmetic in
     if t1 <> t2 && t2 > t1 then current_min := min (t2 - t1) !current_min
   done;
 
   else failwith (Printf.sprintf "unable to calculate min_interval for %s" (to_string t))
 
 let mean_gettime_cost ~measure ~using =
-  assert (getres Process_cpu = 1);
+  assert (getres Process_cpu = Int63.one);
   let count = 10_000_000 in
   let start = gettime using in
   for i = 1 to count do
     ignore (gettime measure);
   done;
   let stop = gettime using in
-  (stop - start) / count
+  Int63_arithmetic.((stop - start) / Int63.of_int count)
+
+let getres            = Ok getres
+let gettime           = Ok gettime
+(* let nanosleep      = Ok nanosleep *)
+let min_interval      = Ok min_interval
+let mean_gettime_cost = Ok mean_gettime_cost
+
+ELSE
+
+let getres            = unimplemented "Posix_clock.getres"
+let gettime           = unimplemented "Posix_clock.gettime"
+(* let nanosleep      = unimplemented "Posix_clock.nanosleep" *)
+let min_interval      = unimplemented "Posix_clock.min_interval"
+let mean_gettime_cost = unimplemented "Posix_clock.mean_gettime_cost"
+
+ENDIF

File base/core/extended/lib/posix_clock.mli

-(* Note: this module is only compiled if the system supports Posix Timers *)
+(* The functions in this module are implemented on systems that support posix timers *)
+
+open Core.Std
 
 type t =
   | Realtime
 val to_string : t -> string
 
 (* returns the resulution of the given clock in nanoseconds *)
-val getres : t -> int
+val getres : (t -> Int63.t) Or_error.t
 
 (* returns the current value of the given clock in nanoseconds *)
-val gettime : t -> int
+val gettime : (t -> Int63.t) Or_error.t
 
 (* sleeps the current thread for the specified number of nanoseconds *)
-(*val nanosleep : t -> int -> unit*)
+(*val nanosleep : (t -> int -> unit) Or_error.t *)
 
 (* [min_interval t] returns the minimum measurable interval for t in nanoseconds *)
-val min_interval : t -> int
+val min_interval : (t -> Int63.t) Or_error.t
 
 (* [cost t] returns the cost of calling gettime with the given t int nanoseconds *)
-val mean_gettime_cost : measure:t -> using:t -> int
+val mean_gettime_cost : (measure:t -> using:t -> Int63.t) Or_error.t
+

File base/core/extended/lib/posix_clock_stubs.c

+#include "config.h"
+#ifdef JSC_POSIX_TIMERS
+
 #include <stdlib.h>
 #include <string.h>
 #include <errno.h>
 
 #include <time.h>
 
+#ifdef JSC_ARCH_SIXTYFOUR
+#  define caml_alloc_int63(v) Val_long(v)
+#else
+#  define caml_alloc_int63(v) caml_copy_int64(v)
+#endif
+
 clockid_t caml_clockid_t_of_caml (value clock_type) {
   switch (Int_val(clock_type)) {
     case 0: return CLOCK_REALTIME;
 value caml_clock_getres (value clock_type) {
   struct timespec tp;
   clock_getres (caml_clockid_t_of_caml (clock_type), &tp);
-  return (Val_int (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec));
+  return (caml_alloc_int63 (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec));
 }
 
 value caml_clock_gettime (value clock_type) {
   struct timespec tp;
   clock_gettime (caml_clockid_t_of_caml (clock_type), &tp);
-  return (Val_int (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec));
+  return (caml_alloc_int63 (((__int64_t)tp.tv_sec * 1000 * 1000 * 1000) + (__int64_t)tp.tv_nsec));
 }
 
 /*
   };
 }
 */
+
+#endif /* JSC_POSIX_TIMERS */

File base/core/extended/lib/std.ml

-INCLUDE "config.mlh"
-
 include Extended_common
 
 module Array = struct
 module Ascii_table = Ascii_table
 module Alternating_primary_backup_assignment = Alternating_primary_backup_assignment
 module Atomic_edit = Atomic_edit
-IFDEF POSIX_TIMERS THEN
 module Bench = Bench
-ENDIF
 module Bin_io_utils = Bin_io_utils
 module Bitarray = Bitarray
 module Cache = Cache
 module Lazy_m = Lazy_m
 module Linebuf = Linebuf
 
-IFDEF LINUX_EXT THEN
 module Linux_ext = struct
   include Core.Std.Linux_ext
   include Extended_linux
 end
-ENDIF
 
 module List = struct
   include Core.Std.List
 module Printc = Printc
 module Process = Process
 module Procfs = Procfs
-IFDEF POSIX_TIMERS THEN
 module Posix_clock = Posix_clock
-ENDIF
 module Readline = Readline
 module Result = struct
   include Core.Std.Result

File base/core/extended/lib/unix_utils.h

+#ifndef UNIX_UTILS_H
+#define UNIX_UTILS_H
+
+#define _GNU_SOURCE
+
+#include <sys/uio.h>
+#include "ocaml_utils.h"
+
+/* Utility definitions */
+
+static inline char * get_bstr(value v_bstr, value v_pos)
+{
+  return (char *) Caml_ba_data_val(v_bstr) + Long_val(v_pos);
+}
+
+static inline struct iovec * copy_iovecs(size_t *total_len, value v_iovecs, int n)
+{
+  struct iovec *iovecs = caml_stat_alloc(sizeof(struct iovec) * n);
+  for (--n; n >= 0; --n) {
+    struct iovec *iovec = &iovecs[n];
+    value v_iovec = Field(v_iovecs, n);
+    value v_iov_base = Field(v_iovec, 0);
+    value v_iov_pos = Field(v_iovec, 1);
+    size_t iov_len = Long_val(Field(v_iovec, 2));
+    iovec->iov_len = iov_len;
+    *total_len += iov_len;
+    iovec->iov_base = get_bstr(v_iov_base, v_iov_pos);
+  }
+  return iovecs;
+}
+
+/* I/O transaction size after which to release the OCaml-lock */
+#define THREAD_IO_CUTOFF 65536
+
+#endif /* UNIX_UTILS_H */

File base/core/extended/lib_test/bench_nano_mutex.ml

 end
 
 let () =
-  Bench.bench
+  Or_error.ok_exn Bench.bench
     (List.map ~f:(fun (name, thunk) -> Bench.Test.create ~name thunk)
        (
          make ~name:"Caml.Mutex" (module Caml.Mutex : Mutex)

File base/core/lib/backtrace_stubs.c

    Much of this module is taken from the OCaml source.
 */
 
+#include "config.h"
+#ifdef JSC_LINUX_EXT
 
 #include <caml/memory.h>
 #include <caml/misc.h>
   fflush(stderr);
   extensible_buffer_free(buf);
 }
+
+#endif /* JSC_LINUX_EXT */

File base/core/lib/linux_ext.ml

   type t
 end
 
+module Clock_unimplemented = struct
+  include Clock0
+  let get               = unimplemented "Linux_ext.Clock.get"
+  let get_time          = unimplemented "Linux_ext.Clock.get_time"
+  let set_time          = unimplemented "Linux_ext.Clock.set_time"
+  let get_resolution    = unimplemented "Linux_ext.Clock.get_resolution"
+  let get_process_clock = unimplemented "Linux_ext.Clock.get_process_clock"
+  let get_thread_clock  = unimplemented "Linux_ext.Clock.get_thread_clock"
+end
+
 (* If you update this type, you also must update linux_tcpopt_bool, in the C stubs. (And
    do make sure you get the order correct) *)
 type tcp_bool_option = TCP_CORK with sexp, bin_io
   let get_thread_clock  = Ok get_thread_clock
 
 end
+ELSE
+module Clock = Clock_unimplemented
 ENDIF
 
 external pr_set_pdeathsig : Signal.t -> unit = "linux_pr_set_pdeathsig_stub"
   let sysinfo = unimplemented "Linux_ext.Sysinfo.sysinfo"
 end
 
-module Clock = struct
-  include Clock0
-  let get               = unimplemented "Linux_ext.Clock.get"
-  let get_time          = unimplemented "Linux_ext.Clock.get_time"
-  let set_time          = unimplemented "Linux_ext.Clock.set_time"
-  let get_resolution    = unimplemented "Linux_ext.Clock.get_resolution"
-  let get_process_clock = unimplemented "Linux_ext.Clock.get_process_clock"
-  let get_thread_clock  = unimplemented "Linux_ext.Clock.get_thread_clock"
-end
+module Clock = Clock_unimplemented
 
 let cores                          = unimplemented "Linux_ext.cores"
 let file_descr_realpath            = unimplemented "Linux_ext.file_descr_realpath"