ysulsky avatar ysulsky committed acd6f9e

auto export

Comments (0)

Files changed (61)

 *.auto.mli
 *.aux
 *.digest
+*.fls
 *.haux
 *.htoc
-*.fls
 *.log
 *.omc
+*.orig
+*.rej
+*.spot
 *.toc
-*.orig
-*.spot
 .*.sw[pabcdef]
 .mydeps
 inline_tests.ml
 glob:base/async/scheduler/configure
 glob:base/async/scheduler/lib/META
 glob:base/async/scheduler/lib/async_scheduler.mlpack
+glob:base/async/scheduler/lib/config.mlh
 glob:base/async/scheduler/myocamlbuild.ml
 glob:base/async/scheduler/setup.data
 glob:base/async/scheduler/setup.ml
 glob:base/core/extended/_tags
 glob:base/core/extended/configure
 glob:base/core/extended/lib/META
+glob:base/core/extended/lib/config.mlh
 glob:base/core/extended/lib/core-extended.mllib
 glob:base/core/extended/lib/core-extended.odocl
 glob:base/core/extended/lib/core_extended.mlpack
+glob:base/core/extended/lib/libcore_extended.clib
 glob:base/core/extended/lib/sexp_pos_parser.ml
 glob:base/core/extended/lib/sexp_pos_parser.mli
 glob:base/core/extended/lib/version_defaults.mlh

base/async/core/lib/basic.ml

       mutable main_execution_context : execution_context sexp_opaque;
       mutable max_num_jobs_per_priority_per_cycle : int;
       mutable uncaught_exception : exn option;
+      mutable num_jobs_run : int;
       mutable cycle_count : int;
       mutable cycle_start : Time.t;
       mutable jobs_left : bool;
       cycle_times : Time.Span.t Tail.t;
+      cycle_num_jobs : int Tail.t;
       events : Clock_event.t Events.t;
     }
 
       main_execution_context = bogus_execution_context;
       max_num_jobs_per_priority_per_cycle = 500;
       uncaught_exception = None;
+      num_jobs_run = 0;
       cycle_start = now;
       cycle_count = 0;
       cycle_times = Tail.create ();
+      cycle_num_jobs = Tail.create ();
       events = Events.create ~now;
       jobs_left = false;
     }
        user-supplied deferred from the right-hand side of connect, and ivar is returned to
        the user prior to being used in the callback, and may be converted to an
        indirection in the case of right-nested binds. *)
+    let i = Ivar.squash ivar in
     let t = repr tdef in
-    let i = Ivar.squash ivar in
     (* i and ivar are the same internally, but have different types *)
-    if not (phys_equal t i) then begin
-      let create_two_bag handler1 handler2 =
+    if not (phys_equal i t) then begin
+      (* Strange order :-/ *)
+      begin match !i, !t with
+      | _ , Empty -> t := Indir ivar
+      | _, Full v -> Ivar.fill ivar v
+      | _, Indir _ -> assert false (* fulfilled by repr *)
+      | Empty, tc -> (* do a swap *) i := tc; t := Indir ivar
+      (* [connect] is only used in bind, whose ivar is only ever exported as a read-only
+         deferred.  Thus, it is impossible for the client to fill the [ivar]. *)
+      | Full _, _ -> assert false
+      | Indir _, _ -> assert false (* fulfilled by Ivar.squash *)
+      (* Tricky cases now. Assume invariant that bags are never shared. *)
+      | Empty_one_handler (run1, ec1), Empty_one_handler (run2, ec2) ->
         let bag = Bag.create () in
-        ignore (Bag.add bag handler1);
-        ignore (Bag.add bag handler2);
+        ignore (Bag.add bag { run = run1; execution_context = ec1});
+        ignore (Bag.add bag { run = run2; execution_context = ec2});
         debug_bag_check bag;
         i := Empty_many_handlers bag;
-        t := Indir ivar in
-      (* Strange order :-/ *)
-      begin match (!t, !i) with
-      | (Empty,   _) -> t := Indir ivar
-      | (Full v,  _) -> Ivar.fill ivar v
-      | (Indir _, _) -> assert false (* fulfilled by repr *)
-      | (tc, Empty) -> (* do a swap *) i := tc; t := Indir ivar
-      (* [connect] is only used in bind, whose ivar is only ever exported as a read-only
-         deferred.  Thus, it is impossible for the client to fill the [ivar]. *)
-      | (_, Full _) -> assert false
-      | (_, Indir _) -> assert false (* fulfilled by Ivar.squash *)
-      (* Tricky cases now. Assume invariant that bags are never shared. *)
-      | (Empty_one_handler (run1, ec1), Empty_one_handler (run2, ec2)) ->
-        let handler1 = { run = run1; execution_context = ec1} in
-        let handler2 = { run = run2; execution_context = ec2} in
-        create_two_bag handler1 handler2
-      | (Empty_one_handler (run, execution_context), Empty_many_handlers bag) ->
+        t := Indir ivar
+      | Empty_many_handlers bag, Empty_one_handler (run, execution_context) ->
+        ignore (Bag.add bag { run; execution_context });
+        debug_bag_check bag;
+        (* no need to rewrite [i], as it's a bag *)
+        t := Indir ivar
+      | Empty_one_handler (run, execution_context), Empty_many_handlers bag ->
         let handler = { run; execution_context } in
         ignore (Bag.add bag handler);
         debug_bag_check bag;
-        (* no need to rewrite i, as it's a bag *)
+        i := !t; (* do a swap *)
         t := Indir ivar
-      | (Empty_many_handlers bag as tc, Empty_one_handler (run, execution_context)) ->
-        let handler = { run; execution_context } in
-        ignore (Bag.add bag handler);
-        debug_bag_check bag;
-        i := tc; (* do a swap *)
-        t := Indir ivar
-      | (Empty_many_handlers bag1, Empty_many_handlers bag2) ->
-        Bag.transfer ~src:bag1 ~dst:bag2;
-        debug_bag_check bag2;
+      | Empty_many_handlers bag_i, Empty_many_handlers bag_t ->
+        Bag.transfer ~src:bag_t ~dst:bag_i;
+        debug_bag_check bag_i;
         t := Indir ivar
       end;
       (* Squash original tdef reference; otherwise, it may grow by two indirections rather

base/async/core/lib/basic.mli

       mutable main_execution_context : Execution_context.t;
       mutable max_num_jobs_per_priority_per_cycle : int;
       mutable uncaught_exception : exn option;
+      mutable num_jobs_run : int;
       mutable cycle_count : int;
       mutable cycle_start : Time.t;
       mutable jobs_left : bool;
       cycle_times : Time.Span.t Tail.t;
+      cycle_num_jobs : int Tail.t;
       events : Clock_event.t Events.t;
     }
 

base/async/core/lib/raw_monitor.ml

 
 let send_exn t ?backtrace exn =
   send_exn t exn
-    ~backtrace:(match backtrace with | None -> `None | Some (`Get | `This _ as x) -> x)
+    ~backtrace:(match backtrace with None -> `None | Some (`Get | `This _ as x) -> x)
 ;;
 
 let try_with_raise_rest ?name f = try_with ?name ~reraise:true f

base/async/core/lib/scheduler.ml

 
 let cycle_times () = Tail.collect t.cycle_times
 
+let cycle_num_jobs () = Tail.collect t.cycle_num_jobs
+
 let cycle_count () = t.cycle_count
 
 let jobs_left () = t.jobs_left
 
+let num_jobs_run () = t.num_jobs_run
+
 let set_max_num_jobs_per_priority_per_cycle int =
   if int <= 0 then
     fail "max_num_jobs_per_priority_per_cycle must be > 0" int <:sexp_of< int >>;
       | job::jobs ->
         if debug then Debug.print "running job %d" (Job.id job);
         begin
-          try Job.run job;
+          try
+            t.num_jobs_run <- t.num_jobs_run + 1;
+            Job.run job;
           with exn -> Monitor.send_exn (Monitor.current ()) exn ~backtrace:`Get;
         end;
         do_batch jobs
     loop t
   in
   fun ~now ->
+    let num_jobs_run_before_cycle = t.num_jobs_run in
     begin match Events.advance_clock t.events ~to_:t.cycle_start with
     | `Not_in_the_future ->
       (* This could conceivably happen with NTP tweaking the clock.  There's no reason
     (* This can potentially add more jobs if somebody is listening to cycle_times
        stream, so we have to check [Jobs.is_empty] before. *)
     Tail.extend t.cycle_times (Time.diff now t.cycle_start);
+    Tail.extend t.cycle_num_jobs (t.num_jobs_run - num_jobs_run_before_cycle);
 ;;
 

base/async/core/lib/scheduler.mli

 val next_upcoming_event : unit -> Time.t option
 val uncaught_exception : unit -> exn option
 val num_pending_jobs : unit -> int
+val num_jobs_run : unit -> int
 val cycle_times : unit -> Time.Span.t Stream.t
+val cycle_num_jobs : unit -> int Stream.t
 val cycle_count : unit -> int
 val set_max_num_jobs_per_priority_per_cycle : int -> unit
 

base/async/extra/lib/tcp.ml

 
 exception Tcp_server_negative_max_connections of int with sexp
 
-let serve ?max_connections ?max_pending_connections ?max_buffer_age ~port
+let serve ?(max_connections=10_000) ?max_pending_connections ?max_buffer_age ~port
     ~on_handler_error handler =
-  begin
-    match max_connections with
-    | None -> ()
-    | Some max_connections ->
-      if max_connections <= 0
-      then raise (Tcp_server_negative_max_connections max_connections)
-  end;
   Deferred.create (fun ready ->
-    let num_connections = ref 0 in
-    let at_max_connections () =
-      match max_connections with
-      | None -> false
-      | Some max_connections -> !num_connections >= max_connections
-    in
+    if max_connections <= 0 then
+      raise (Tcp_server_negative_max_connections max_connections);
     let s = create_socket () in
     close_sock_on_error s (fun () ->
       Socket.setopt s Socket.Opt.reuseaddr true;
       >>| Socket.listen ?max_pending_connections)
     >>> fun s ->
     Ivar.fill ready ();
-    let rec loop () =
-      Socket.accept s
-      >>> fun (client_s, addr) ->
-      if at_max_connections ()
-      then begin
-        let r, w = reader_writer_of_sock ?max_buffer_age client_s in
-        close_connection r w
-        >>> fun () ->
-        loop ()
-      end
-      else begin
-        num_connections := !num_connections + 1;
-        begin
-          handle_client ?max_buffer_age client_s addr handler
-          >>> fun res ->
-          num_connections := !num_connections - 1;
-          match res with
-          | Ok () -> ()
-          | Error e ->
-            match on_handler_error with
-            | `Ignore -> ()
-            | `Raise  -> raise e
-            | `Call f -> f addr e
+    let num_connections   = ref 0 in
+    let accept_is_pending = ref false in
+    let rec accept_loop () =
+      if !num_connections < max_connections && not !accept_is_pending then begin
+        accept_is_pending := true;
+        Socket.accept s
+        >>> fun (client_s, addr) ->
+        accept_is_pending := false;
+        incr num_connections;
+        accept_loop ();
+        handle_client ?max_buffer_age client_s addr handler
+        >>> fun res ->
+        begin match res with
+        | Ok () -> ()
+        | Error e ->
+          match on_handler_error with
+          | `Ignore -> ()
+          | `Raise  -> raise e
+          | `Call f -> f addr e
         end;
-        loop ()
+        decr num_connections;
+        accept_loop ()
       end
     in
-    loop ())
+    accept_loop ())
 ;;
 
 let connect_sock ~host ~port = connect_sock ~host ~port ()

base/async/extra/lib/tcp.mli

 
 (** [connect ~host ~port] is a convenience wrapper around [connect_sock] that
     returns a reader and writer on the socket. *)
-val connect :
-     ?max_buffer_age:Time.Span.t
+val connect
+  :  ?max_buffer_age:Time.Span.t
   -> ?interrupt:unit Deferred.t
   -> ?reader_buffer_size:int
   -> host:string

base/async/extra/lib/tcp_file.ml

     | `No      -> Deferred.return 0
     | `Unknown -> failwithf "unable to open file: %s" filename ()
     | `Yes ->
+      (* There is no strong case for using [exclusive:true] since locks are advisory, but
+         it expresses something in the code that we want to be true, and shouldn't hurt.
+      *)
       Reader.with_file ~exclusive:true filename
         ~f:(fun r -> Pipe.drain_and_count (Reader.lines r))
   ;;
   let stop_serving = stop_serving_internal
 
   let close ?(stop_serving=true) t =
-    if not t.File.closed then begin
+    if t.File.closed then
+      Deferred.unit
+    else begin
       t.File.closed <- true;
       if stop_serving then stop_serving_internal t;
       Tail.close_if_open t.File.tail;
       | `Writer writer -> File_writer.close writer
       | `This_is_a_static_file -> Deferred.unit
     end
-    else
-      Deferred.unit
 
   exception Attempt_to_flush_static_tcp_file of string with sexp
 

base/async/scheduler/lib/async_unix.ml

 
 let nice i = Unix.nice i
 
-let cores () = syscall_exn (fun () -> Linux_ext.cores ())
+INCLUDE "config.mlh"
+IFDEF LINUX_EXT THEN
+let cores () = syscall_exn (fun () -> Some (Linux_ext.cores ()))
+ELSE
+let cores () = return None
+ENDIF
+
+let cores_exn () =
+  cores () >>| Option.value_exn_message "cores: only supported on Linux"
 
 (* basic input/output *)
 
     }
 
     let bool = make Unix.getsockopt Unix.setsockopt
-    let bool_tcp = make Linux_ext.gettcpopt_bool Linux_ext.settcpopt_bool
     let int = make Unix.getsockopt_int Unix.setsockopt_int
     let optint = make Unix.getsockopt_optint Unix.setsockopt_optint
     let float = make Unix.getsockopt_float Unix.setsockopt_float
     let acceptconn = bool "acceptconn" U.SO_ACCEPTCONN
 
     let nodelay = bool "nodelay" U.TCP_NODELAY
-    let cork = bool_tcp "cork" Linux_ext.TCP_CORK
 
     let sndbuf = int "sndbuf" U.SO_SNDBUF
     let rcvbuf = int "rcvbuf" U.SO_RCVBUF

base/async/scheduler/lib/async_unix.mli

 
 val nice : int -> int
 
-(** [cores ()] Returns the number of cores *)
-val cores : unit -> int Deferred.t
+(** [cores ()] Returns the number of cores, or None if we're unable to
+    detect the correct number. *)
+val cores : unit -> int option Deferred.t
+val cores_exn : unit -> int Deferred.t
 
 type open_flag =
   [ `Rdonly

base/async/scheduler/lib/raw_scheduler.ml

     have_lock_do_cycle t)
 ;;
 
+INCLUDE "config.mlh"
 let create_thread t ?(default_thread_name_first16 = "helper-thread") squeue =
   t.num_live_threads <- t.num_live_threads + 1;
   let dead () = t.num_live_threads <- t.num_live_threads - 1 in
   let (_ : Thread.t) = Thread.create (fun () ->
-    let last_thread_name = ref "" in
-    let set_thread_name thread_name =
-      if String.(<>) thread_name !last_thread_name then begin
-        Linux_ext.pr_set_name_first16 thread_name;
-        last_thread_name := thread_name;
-      end;
+    let set_thread_name =
+IFDEF LINUX_EXT THEN
+      let last_thread_name = ref "" in
+      fun thread_name ->
+        if String.(<>) thread_name !last_thread_name then begin
+          Linux_ext.pr_set_name_first16 thread_name;
+          last_thread_name := thread_name;
+        end
+ELSE
+      ignore
+ENDIF
     in
     set_thread_name default_thread_name_first16;
     let rec loop () =
 
 let block_on_async (type a) (f : unit -> a Deferred.t) =
   let t = the_one_and_only ~should_lock:false () in
-  if (am_in_async t)
+  if (not (is_main_thread ())) && (am_in_async t)
   then raise Called_block_on_async_from_async;
 
   (* Only create a scheduler thread if the scheduler isn't already running. *)
     | `Available v -> v
     | `Blocked_wait_on_squeue q -> Squeue.pop q
   in
-  if is_main_thread () then Nano_mutex.lock_exn t.mutex;
+  if is_main_thread () && (not (am_in_async t)) then Nano_mutex.lock_exn t.mutex;
   res
 ;;
 

base/async/scheduler/lib/scheduler.mli

 val schedule : ((unit -> unit) -> unit) with_options
 
 (** [block_on_async f] runs [f ()] in the async world and blocks until it becomes
-    determined.  This function is safe to call from async or non-async code and
-    does not require explicit scheduler management. *)
+    determined.  This function is can be called from any thread not running within
+    async, and does not require explicit scheduler management. *)
 val block_on_async :     (unit -> 'a Deferred.t) -> ('a, exn) Result.t
 val block_on_async_exn : (unit -> 'a Deferred.t) -> 'a
 
 (** [run_in_async_wait f] is like [block_on_async f], except that it will raise
-    an exception if it is called from the main thread or from within async.
+    an exception if it is called from the main thread as well as from within async.
     Upon returning from [run_in_async_wait], it is guaranteed that the caller
     does not have the async lock.  For experts only; casual users should stick
     with block_on_async. **)

base/async/scheduler/lib/writer.ml

   t.back <- 0;
 ;;
 
-let die t exn = stop_permanently t; raise exn
+let die t error = stop_permanently t; Error.raise error
 
 (* We used to use [after (sec 5.)] as the default value for [force_close] for all kinds of
    underlying fds. This was problematic, because it silently caused data in the writer's
    should be the best. *)
 let thread_io_cutoff = 262_144
 
-exception Ready_to_got_bad_fd of t with sexp
-exception Syscall_returned_negative_result of t * int with sexp
-exception Write_got_EBADF of t with sexp
-exception Writer_fd_unexpectedly_closed of t with sexp
-exception Wrote_more_than_received of t with sexp
-exception Wrote_nonzero_amount_but_IO_queue_is_empty of t with sexp
-
 (* If whe writer was closed, we should be quiet.  But if it wasn't, then someone was
    monkeying around with the fd behind our back, and we should complain. *)
-let fd_closed t = if not t.is_closed then raise (Writer_fd_unexpectedly_closed t)
+let fd_closed t =
+  if not t.is_closed then fail "writer fd unexpectedly closed " t <:sexp_of< t >>
+;;
 
 let rec start_write t =
   assert (t.background_writer_state = `Running);
       if n >= 0 then
         write_finished t n
       else
-        die t (Syscall_returned_negative_result (t, n))
+        die t (Error.create "write system call returned negative result" (t, n)
+                 <:sexp_of< t * int >>)
     | `Error (U.Unix_error ((U.EWOULDBLOCK | U.EAGAIN), _, _)) ->
       write_when_ready t
     | `Error (U.Unix_error (U.EBADF, _, _)) ->
-      die t (Write_got_EBADF t)
+      die t (Error.create "write got EBADF" t <:sexp_of< t >>)
     | `Error ((U.Unix_error ((U.EPIPE | U.ECONNRESET), _, _)) as exn) ->
       (* [t.got_epipe] is empty since once we reach this point, we stop the writer
          permanently, and so will never reach here again. *)
       Ivar.fill t.got_epipe ();
       stop_permanently t;
       if t.raise_epipe then raise exn;
-    | `Error exn -> die t exn
+    | `Error exn -> die t (Error.of_exn exn)
   in
   let should_write_in_thread =
     not (Fd.supports_nonblock t.fd)
   assert (t.background_writer_state = `Running);
   Fd.ready_to t.fd `Write
   >>> function
-    | `Bad_fd -> die t (Ready_to_got_bad_fd t)
+    | `Bad_fd -> die t (Error.create "writer ready_to got Bad_fd" t <:sexp_of< t >>)
     | `Closed -> fd_closed t
     | `Ready -> start_write t
 
   Io_stats.update io_stats ~kind:(Fd.kind t.fd) ~bytes:int63_bytes_written;
   t.bytes_written <- Int63.(int63_bytes_written + t.bytes_written);
   if Int63.(t.bytes_written > t.bytes_received) then
-    die t (Wrote_more_than_received t);
+    die t (Error.create "writer wrote more bytes than it received" t <:sexp_of< t >>);
   fill_flushes t;
   t.scheduled_bytes <- t.scheduled_bytes - bytes_written;
   (* Remove processed iovecs from t.scheduled. *)
     match Queue.dequeue t.scheduled with
     | None ->
       if bytes_written > 0 then
-        die t (Wrote_nonzero_amount_but_IO_queue_is_empty t)
+        die t (Error.create "writer wrote nonzero amount but IO_queue is empty" t
+                 <:sexp_of< t >>)
     | Some ({ IOVec. buf; pos; len }, kind) ->
       if bytes_written >= len then begin
         (* Current I/O-vector completely written.  Internally generated buffers get
         pos_len : int;
       }
     with sexp
-
-    exception E of t with sexp
   end
 
   let write_bin_prot t writer v =
       let pos            = writer.Bin_prot.Type_class.write buf ~pos:pos_len v in
       if pos - start_pos <> tot_len then begin
         let module W = Write_bin_prot_bug in
-        raise (W.E { W.
-                     pos;
-                     start_pos;
-                     tot_len;
-                     len;
-                     len_len;
-                     pos_len;
-                   })
+        fail "write_bin_prot" { W. pos; start_pos; tot_len; len; len_len; pos_len }
+        <:sexp_of< Write_bin_prot_bug.t >>
       end;
       maybe_start_writer t;
     end
   val write_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit
 end)
 
+INCLUDE "config.mlh"
+IFDEF LINUX_EXT THEN
 let write_marshal t ~flags a =
   schedule_unscheduled t `Keep;
   let iovec =
   add_iovec t `Destroy iovec ~count_bytes_as_received:true;
   maybe_start_writer t
 ;;
+ENDIF
 
 let send t s =
   write t (string_of_int (String.length s) ^ "\n");
   ensure_not_closed t; schedule_bigstring t ?pos ?len bstr
 let write ?pos ?len t s       = ensure_not_closed t; write ?pos ?len t s
 let writef t                  = ensure_not_closed t; writef t
+IFDEF LINUX_EXT THEN
 let write_marshal t ~flags a  = ensure_not_closed t; write_marshal t ~flags a
+ENDIF
 let write_sexp ?hum t s       = ensure_not_closed t; write_sexp ?hum t s
 let write_bigsubstring t s    = ensure_not_closed t; write_bigsubstring t s
 let write_substring t s       = ensure_not_closed t; write_substring t s
   perm land (lnot umask)
 ;;
 
-exception Could_not_create_file of string * exn with sexp
-
 let save ?temp_prefix ?perm ?fsync:(do_fsync = false) file ~contents =
   Async_sys.file_exists file
   >>= fun file_exists ->
     | Ok () -> ()
     | Error exn ->
       whenever (Unix.unlink temp_file);
-      raise (Could_not_create_file (file, exn))
+      fail "Writer.save could not create file" (file, exn) <:sexp_of< string * exn >>
 ;;
 
 let sexp_to_buffer ?(hum = true) ~buf sexp =

base/async/scheduler/lib/writer.mli

     before the data itself.  This is the format that Reader.read_bin_prot reads. *)
 val write_bin_prot : t -> 'a Bin_prot.Type_class.writer -> 'a -> unit
 
+INCLUDE "config.mlh"
+IFDEF LINUX_EXT THEN
 (** serialize data using marshal and write it to the writer *)
 val write_marshal :
   t -> flags:Marshal.extern_flags list -> 'a -> unit
+ENDIF
 
 (** Unlike the [write_] functions, all functions starting with [schedule_] require
     flushing or closing of the writer after returning before it is safe to modify the

base/async/scheduler/oasis.sh

 #!/bin/bash
 set -e -u -o pipefail
 
+enable_linux=false
+enable_linux_default="--disable-linux"
+case $(ocamlc -config | awk '$1 == "system:" {print $2}') in
+    linux|linux_elf)
+        enable_linux=true
+        enable_linux_default="--enable-linux"
+    ;;
+esac
+
+opts=( "$@" )
+for ((i=0; i<$#; i++)); do
+    case ${opts[$i]} in
+        --enable-linux)  enable_linux=true;  enable_linux_default= ;;
+        --disable-linux) enable_linux=false; enable_linux_default= ;;
+    esac
+done
+
 here="$(dirname "${BASH_SOURCE[0]}")"
 
 my_join () {
 XStdFilesINSTALLFilename: INSTALL
 XStdFilesREADME: false
 
+Flag linux
+  Description: Enable linux specific extensions
+  Default$:    $enable_linux
+
+PreBuildCommand: mkdir -p _build; cp lib/*mlh _build/
+PreDistCleanCommand: \$rm lib/version_defaults.mlh lib/config.mlh
 
 Library async_scheduler
   Path:               lib
 # OASIS_START
 # OASIS_STOP
 <lib/*.ml{,i}>: syntax_camlp4o
+"lib/async_unix.ml": pkg_camlp4.macro
+"lib/raw_scheduler.ml": pkg_camlp4.macro
+<lib/writer.ml{,i}>: pkg_camlp4.macro
+EOF
+
+cat >$here/lib/config.mlh <<EOF
+$(if [[ "$enable_linux" == "true" ]]; then echo "DEFINE LINUX_EXT"; fi)
 EOF
 
 cd $here
 oasis setup
-./configure "$@"
+./configure "$enable_linux_default" "$@"
 

base/core/extended/lib/bench.mli

 open Core.Std
 
+(* Note: this module is only compiled if the system supports Posix Timers *)
+
 module Test : sig
   type t
   val create : ?name:string -> ?size:int -> (unit -> unit) -> t

base/core/extended/lib/command.ml

           ~f:(fun acc x -> max acc x)
           ~init:(String.length x)
       in
-      let max_width = Option.value (Console.width ()) ~default:80 in
+      let max_width =
+        match Console.width () with
+        | `Not_a_tty | `Not_available -> 80
+        | `Cols cols -> cols
+      in
       List.concat
         (List.map list
            ~f:(fun (cmd,desc) ->

base/core/extended/lib/console.ml

 
 end
 
+INCLUDE "config.mlh"
+IFDEF LINUX_EXT THEN
 let width () =
   if Unix.isatty Unix.stdout then
-    Some (snd (Linux_ext.get_terminal_size ()))
+    `Cols (snd (Linux_ext.get_terminal_size ()))
   else
-    None
+    `Not_a_tty
+ELSE
+let width () = `Not_available
+ENDIF
 
 let print_list oc l =
-  match width () with
-  | None ->
+  match (width () :> [ `Cols of int | `Not_a_tty | `Not_available ]) with
+  | `Not_a_tty | `Not_available ->
       List.iter l ~f:(fun (s,_) -> print_endline s)
-  | Some cols ->
+  | `Cols cols ->
       let print_styled (s,style) =
         Ansi.output_string style oc s
       in

base/core/extended/lib/console.mli

 
 (** The width in characters of the current output. Returns [None] if stdout is
     not connected to a tty.*)
-val width : unit -> int option
+val width : unit -> [ `Cols of int | `Not_a_tty | `Not_available ]
 
 (** print a list in a columnize way (like the output of ls) *)
 val print_list : out_channel -> (string * Ansi.attr list) list -> unit

base/core/extended/lib/libcore_extended.clib

-# OASIS_START
-# DO NOT EDIT (digest: 422c2b09ba2d0a8511a6e86fe2bc7476)
-extended_sys_stubs.o
-extended_unix_stubs.o
-fork_exec.o
-low_level_debug_stubs.o
-posix_clock_stubs.o
-syslog_stubs.o
-# OASIS_STOP

base/core/extended/lib/posix_clock.ml

-type t = 
+type t =
   | Realtime
   | Monotonic
   | Process_cpu

base/core/extended/lib/posix_clock.mli

-type t = 
+(* Note: this module is only compiled if the system supports Posix Timers *)
+
+type t =
   | Realtime
   | Monotonic
   | Process_cpu

base/core/extended/lib/posix_clock_stubs.c

 
 #include <time.h>
 
-#ifdef CLOCK_REALTIME
 clockid_t caml_clockid_t_of_caml (value clock_type) {
   switch (Int_val(clock_type)) {
     case 0: return CLOCK_REALTIME;
   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));
 }
-#else
-
-value caml_clock_getres (value __attribute__((unused)) clock_type) {
-  unix_error(ENOSYS,"clock_getres" , Nothing);
-}
-
-value caml_clock_gettime (value __attribute__((unused)) clock_type) {
-  unix_error(ENOSYS,"clock_getres" , Nothing);
-}
-
-#endif
 
 /*
 value caml_clock_nanosleep (value clock_type, value nanoseconds_v) {
   tp.tv_sec = 0;
   tp.tv_nsec = Int_val(nanoseconds_v);
   tp.tv_nsec = tp.tv_nsec + Int_val(nanoseconds_v);
-  
+
   while (1 == 1) {
     if (clock_nanosleep (clockid, 0, &tp, &remaining) == 0) {
       if (remaining.tv_sec == 0 && remaining.tv_nsec == 0) {

base/core/extended/lib/pp.ml

   and ($//) = ($//)
 end
 
-let vlist, hlist =
+let vlist, alist, hlist =
   let group f l = f (List.fold l ~init:empty ~f:(fun pp p -> pp $ break $ p)) in
-  group vgrp, group hgrp
+  group vgrp, group agrp, group hgrp
 

base/core/extended/lib/pp.mli

 
 (** {[ vlist [x1,..,xn] = vgrp [x1; break; x2; ...; break; xn) ]} *)
 val vlist : t list -> t
+
+val alist : t list -> t

base/core/extended/lib/std.ml

+INCLUDE "config.mlh"
+
 include Extended_common
 
 module Array = struct
 end
 module Ascii_table = Ascii_table
 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_list = Lazy_list
 module Lazy_m = Lazy_m
 module Linebuf = Linebuf
-#if !defined(JSC_NO_LINUX_EXT)
+
+IFDEF LINUX_EXT THEN
 module Linux_ext = struct
   include Core.Std.Linux_ext
   include Extended_linux
 end
-#else
-#warning "linux_ext not supported, not being included in Core_extended.Std"
-#endif
+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

base/core/extended/oasis.sh

 #!/bin/bash
 set -e -u -o pipefail
 
+enable_linux=false
+enable_linux_default="--disable-linux"
+case $(ocamlc -config | awk '$1 == "system:" {print $2}') in
+    linux|linux_elf)
+        enable_linux=true
+        enable_linux_default="--enable-linux"
+    ;;
+esac
+
+enable_timers=false
+enable_timers_default="--disable-posix-timers"
+if [[ $(getconf _POSIX_TIMERS 2>/dev/null) -ge 200112 ]]; then
+    enable_timers=true
+    enable_timers_default="--enable-posix-timers"
+fi
+
+opts=( "$@" )
+for ((i=0; i<$#; i++)); do
+    case ${opts[$i]} in
+        --enable-linux)  enable_linux=true;  enable_linux_default= ;;
+        --disable-linux) enable_linux=false; enable_linux_default= ;;
+        --enable-posix-timers)  enable_timers=true;  enable_timers_default= ;;
+        --disable-posix-timers) enable_timers=false; enable_timers_default= ;;
+    esac
+done
+
 here="$(dirname "${BASH_SOURCE[0]}")"
 my_join () {
     FIRST="true"
         bname="$(basename $i)"
         j=${bname%%.ml*};
         case $j in
-            malloc) continue;;
-            extended_linux) continue;;
+            malloc|extended_linux)
+                if [ "$enable_linux" == "false" ]; then continue; fi;;
+            bench|posix_clock)
+                if [ "$enable_timers" == "false" ]; then continue; fi;;
             inline_tests_runner) continue;;
-            type) continue;;
             *);;
         esac
         echo -n "${j:0:1}" | tr "[:lower:]" "[:upper:]"; echo ${j:1};
         bname="$(basename $i)"
         j=${bname%%.?};
         case $j in
-            malloc_stubs) continue;;
-            extended_linux_stubs) continue;;
+            malloc_stubs|extended_linux_stubs)
+                if [ "$enable_linux" == "false" ]; then continue; fi;;
+            posix_clock_stubs)
+                if [ "$enable_timers" == "false" ]; then continue; fi;;
             *);;
         esac
         echo "$bname"
 }
 
 MODULES="$(list_mods | sort -u | my_join)"
+CSOURCES="fork_exec.h,$(list_stubs | sort -u | my_join)"
 
 cat >$here/_oasis <<EOF
 #AUTOGENERATED FILE; EDIT oasis.sh INSTEAD
 XStdFilesINSTALLFilename: INSTALL
 XStdFilesREADME: false
 
-PreBuildCommand: mkdir -p _build; cp lib/*mlh _build/
+Flag linux
+  Description: Enable linux specific extensions
+  Default\$:   $enable_linux
+
+Flag "posix-timers"
+  Description: Enable POSIX timers
+  Default\$:   $enable_timers
+
+PreBuildCommand: mkdir -p _build/lib; cp lib/*.mlh _build/; cp ../lib/*.h _build/lib/
+PreDistCleanCommand: \$rm lib/version_defaults.mlh lib/config.mlh
 
 Library core_extended
   Path:               lib
   FindlibName:        core_extended
   Pack:               true
-  Modules:${MODULES}
-  CCopt+:              -I../../lib
-#ls *.{c,h} | sort
-  CSources:           fork_exec.h,$(list_stubs | sort -u|my_join)
+  Modules:            ${MODULES}
+  CSources:           ${CSOURCES}
+  CCOpt+:             -Ilib
 
   BuildDepends:       sexplib.syntax,
                       sexplib,
 # OASIS_START
 # OASIS_STOP
 <lib/*.ml{,i}>: syntax_camlp4o
-"lib/std.ml": pp(cpp -undef -traditional -Werror -I.)
+"lib/std.ml": pkg_camlp4.macro
 "lib/command.ml": pkg_camlp4.macro
+"lib/console.ml": pkg_camlp4.macro
 "lib/core_command.ml": pkg_camlp4.macro
 EOF
 
 EOF
 fi
 
+cat >$here/lib/config.mlh <<EOF
+$(if [[ "$enable_linux"  == "true" ]]; then echo "DEFINE LINUX_EXT"; fi)
+$(if [[ "$enable_timers" == "true" ]]; then echo "DEFINE POSIX_TIMERS"; fi)
+EOF
+
 cd $here
 oasis setup
-./configure "$@"
+./configure "$enable_timers_default" "$enable_linux_default" "$@"

base/core/lib/avltree.ml

   in
   fun t ~compare ~added ~key ~data ->
     let x = add_if_not_exists t added compare key data in
-    if !added then balance x else begin
-      assert (x = t);
+    if !added then balance x else
       t
-    end
 
 let rec find t ~compare k =
   (* A little manual unrolling of the recursion.

base/core/lib/common.mli

 
 val failwithf    : ('r, unit, string, unit -> _) format4 -> 'r
 val invalid_argf : ('r, unit, string, unit -> _) format4 -> 'r
-val ksprintf     : (string -> 'a) -> ('r, unit, string, 'a) format4 -> 'r
 
 (* The following [sexp_of_X] functions ignore their argument and return [Sexp.Atom "_"].
    They are useful when one has a polymorphic type ['a t] with a sexp converter [val

base/core/lib/commutative_group.ml

    4: commutativity: a+b = b+a
 *)
 
-
 module type S = sig
   type t with sexp  (* an element of the group *)
 

base/core/lib/core_hashtbl.ml

 
 let partition t ~f = partitioni t ~f:(fun ~key:_ ~data -> f data)
 
-let remove_all = remove
-
 let remove_one t key =
   match find t key with
   | None -> ()

base/core/lib/core_hashtbl_intf.ml

     val of_alist_multi : ('a Key.t, ('a Key.t * 'b) list -> ('a, 'b list) t) with_options
 
 
-
     (* create_mapped get_key get_data [x1,...,xn] =
          of_alist [get_key x1, get_data x1; ...; get_key xn, get_data xn] *)
     val create_mapped :
 
     val of_alist_multi : ('a, ('a * 'b) list -> ('a, 'b list) t) with_poly_options
 
-
-
     (* create_mapped get_key get_data [x1,...,xn] =
          of_alist [get_key x1, get_data x1; ...; get_key xn, get_data xn] *)
     val create_mapped :

base/core/lib/core_string.ml

 module T = struct
   type t = string with sexp, bin_io
 
-  let compare (x : string) y = Pervasives.compare x y
+  let compare = String.compare
   (* = on two strings avoids calling compare_val, which is what happens
      with String.compare *)
   let equal (x : string) y = x = y

base/core/lib/core_unix.ml

 
 let is_rw_open_flag = function O_RDONLY | O_WRONLY | O_RDWR -> true | _ -> false
 
-let openfile filename ~mode ~perm =
+let openfile ?(perm = 0o644) ~mode filename =
   let mode_sexp () = sexp_of_list sexp_of_open_flag mode in
   if not (Core_list.exists mode ~f:is_rw_open_flag) then
     failwithf "Unix.openfile: no read or write flag specified in mode: %s"
   | `Extend of (string * string) list
 ] with sexp
 
-let create_process_env ?working_dir ~prog ~args ~(env:env) () =
+let create_process_env ?working_dir ~prog ~args ~env () =
   let module Map = Core_map in
   let env_map =
     let current, env =
       match env with
       | `Replace env -> [], env
       | `Extend env ->
-          List.map (Array.to_list (Unix.environment ()))
-            ~f:(fun s -> String.lsplit2_exn s ~on:'='), env
+        List.map (Array.to_list (Unix.environment ()))
+          ~f:(fun s -> String.lsplit2_exn s ~on:'='), env
     in
     List.fold_left (current @ env) ~init:Map.empty
       ~f:(fun map (key, data) -> Map.add map ~key ~data)

base/core/lib/core_unix.mli

 (** The type of file access rights. *)
 type file_perm = int with sexp
 
-
-(** Open the named file with the given flags. Third argument is
-   the permissions to give to the file if it is created. Return
-   a file descriptor on the named file. *)
-val openfile : string -> mode:open_flag list -> perm:file_perm -> File_descr.t
+(** Open the named file with the given flags. Third argument is the permissions to give to
+    the file if it is created. Return a file descriptor on the named file. Default
+    permissions 0o644. *)
+val openfile : ?perm:file_perm -> mode:open_flag list -> string -> File_descr.t
 
 (** Close a file descriptor. *)
 val close : ?restart:bool -> File_descr.t -> unit
 
 (** [create_process_env ~prog ~args ~env] as create process, but takes an
  * additional parameter that extends, or replaces the current environment.
+ * No effort is made to ensure that the keys passed in as env are unique, so
+ * if an environment variable is set twice the second version will override
+ * the first.
  *)
 val create_process_env :
   ?working_dir : string

base/core/lib/date.ml

 module Time = Time_internal.T
 
 (* Create a local private date type to ensure that all dates are created via
-    Date.create.
+   Date.create.
 *)
 module T : sig
-  type t = { y: int; m: Month.t; d: int; }
+  type t = private { y: int; m: Month.t; d: int; }
 
   include Binable with type t := t
   val create : y:int -> m:Month.t -> d:int -> t
       invalid_argf "Date.create ~y:%d ~m:%s ~d:%d error: %s"
         year (Month.to_string month) day msg ()
     in
+    if year < 0 || year > 9999 then invalid "year outside of [0..9999]";
     if day <= 0 then invalid "day <= 0";
     begin match Month.get month with
     | `Apr | `Jun | `Sep | `Nov ->
   buf.[7] <- '-';
   blit_string_of_int_2_digits buf ~pos:8 t.d;
   buf
+;;
 
 let to_string = to_string_iso8601_extended
 
   blit_string_of_int_2_digits buf ~pos:4 (Month.to_int t.m);
   blit_string_of_int_2_digits buf ~pos:6 t.d;
   buf
+;;
 
 (** MM/DD/YYYY *)
-let to_string_old t =
+let to_string_american t =
   let buf = String.create 10 in
   blit_string_of_int_2_digits buf ~pos:0 (Month.to_int t.m);
   buf.[2] <- '/';
   buf.[5] <- '/';
   blit_string_of_int_4_digits buf ~pos:6 t.y;
   buf
+;;
 
 let parse_year4 str pos = parse_four_digits str pos
 
     ~y:(parse_year4 str pos)
     ~m:(parse_month str (pos + 4))
     ~d:(parse_day str (pos + 6))
+;;
 
 let of_string s =
   let invalid () = failwith ("invalid date: " ^ s) in
     (* assume YYYYMMDD *)
     month_num ~year:0 ~month:4 ~day:6
   end else invalid ()
+;;
 
 let of_string s =
   try of_string s with
   | exn -> invalid_argf "Date.of_string (%s): %s" s (Exn.to_string exn) ()
+;;
 
 module Sexpable = struct
 
   let t_of_sexp = function
     | Sexp.Atom s -> of_string s
     | Sexp.List _ as sexp -> Old_date.to_date (Old_date.t_of_sexp sexp)
+  ;;
 
   let t_of_sexp s =
     try
     with
     | (Sexplib.Conv.Of_sexp_error _) as exn -> raise exn
     | Invalid_argument a -> Sexplib.Conv.of_sexp_error a s
+  ;;
 
   let sexp_of_t t = Sexp.Atom (to_string t)
 end
       let n = Month.compare t1.m t2.m in
       if n <> 0 then n
       else Int.compare t1.d t2.d
+  ;;
 end)
 
 include (Hashable.Make_binable (struct
     ~y:(tm.Unix.tm_year + 1900)
     ~m:(Month.of_int_exn (tm.Unix.tm_mon + 1))
     ~d:tm.Unix.tm_mday
+;;
 
 (* This, and to_time_internal below, should only be used in add_days and diff in Date.
   * We need to do this here instead of using the normal Time.of_local_date_ofday because
       tm_yday = 0;
       tm_isdst = false;
   }
+;;
 
 let to_time_internal t =
   let tm_date = to_tm t in
         (to_string t) (Unix.error_message e) s1 s2 ()
   in
   Time.of_float time
+;;
 
 let of_time_internal time = of_tm (Unix.localtime (Float.round_down (Time.to_float time)))
 
 let add_days t n =
   let time = to_time_internal t in
   of_time_internal (Time.add time (Span.of_day (Float.of_int n)))
+;;
 
 let add_months t n =
   let total_months = (Month.to_int t.m) + n in
       try_create (d - 1)
   in
   try_create t.d
+;;
 
 let diff t1 t2 =
   Int.of_float (Float.round (Span.to_day
     (Time.diff (to_time_internal t1) (to_time_internal t2))))
+;;
 
 (* returns a Weekday.t *)
 let day_of_week t =
   let sec, _ = Unix.mktime uday in
   let unix_wday = (Unix.localtime sec).Unix.tm_wday in
   Weekday.of_int_exn unix_wday
+;;
 
 let is_weekend t =
   Weekday.is_sun_or_sat (day_of_week t)
+;;
 
-let is_weekday t =
-  not (is_weekend t)
+let is_weekday t = not (is_weekend t)
 
 let is_business_day t ~is_holiday =
   is_weekday t
   && not (is_holiday t)
+;;
 
 let add_days_skipping t ~skip n =
   let step = if Int.(>=) n 0 then 1 else -1 in
 
 let add_business_days t ~is_holiday n =
   add_days_skipping t n ~skip:(fun d -> is_weekend d || is_holiday d)
+;;
 
 let dates_between ~min:t1 ~max:t2 =
   let rec loop t l =
     else loop (add_days t (-1)) (t::l)
   in
   loop t2 []
+;;
 
 let weekdays_between ~min ~max =
   let all_dates = dates_between ~min ~max in
           then None
           else Some date)
     )
+;;
 
 let business_dates_between ~min ~max ~is_holiday =
   weekdays_between ~min ~max
   |! List.filter ~f:(fun d -> not (is_holiday d))
+;;
 
 let rec previous_weekday t =
   let previous_day = add_days t (-1) in
     previous_day
   else
     previous_weekday previous_day
+;;
 
 module Export = struct
-  type _date = t = { y: int; m: Month.t; d: int; }
+  type _date = t = private { y: int; m: Month.t; d: int; }
 end

base/core/lib/date.mli

 val of_string_iso8601_basic : string -> pos:int -> t (* YYYYMMDD *)
 val to_string_iso8601_basic : t -> string            (* YYYYMMDD *)
 
-val to_string_old : t -> string              (* MM/DD/YYYY *)
+val to_string_american : t -> string              (* MM/DD/YYYY *)
 
 val pp : Format.formatter -> t -> unit
 
 (* Monday through Friday are business days, unless they're a holiday *)
 val is_business_day : t -> is_holiday:(t -> bool) -> bool
 
+(* [add_days t n] adds n days to t and returns the resulting date.  This is done by adding
+   (or subtracting in the case of a negative n) one day at a time in a loop until n is 0. 
+   This is simple to reason about, but inefficient for large values of n.
+*)
 val add_days : t -> int -> t
 
 (** [add_months t n] returns date with max days for the month if the date would be
 val diff : t -> t -> int
 
 (** [add_weekdays t 0] returns the next weekday if [t] is a weekend and [t]
-    otherwise *)
+    otherwise.  Identical to calling add_days where the remaining count of days to
+    add/subtract isn't changed as the loop moves over weekend days *)
 val add_weekdays : t -> int -> t
 
 (** [add_business_days t ~is_holiday n] returns a business day even when
     n=0. [add_business_days ~is_holiday:(fun _ -> false) ...] is the same as
     [add_weekdays]. Use [Pnl_db.Calendar_events.is_holiday] as a conveninent
-    holiday function. *)
+    holiday function. 
+*)
 val add_business_days : t -> is_holiday:(t -> bool) -> int -> t
 
 (* the following returns a closed interval (endpoints included) *)

base/core/lib/discover.sh

 #include <sys/socket.h>
 # $LINENO "$(basename "${BASH_SOURCE[0]}")"
 int main () {
-  $(cpp_test LINUX_EXT "defined(LINUX_EXT)")
+  $(cpp_test LINUX_EXT    "defined(LINUX_EXT)")
+  $(cpp_test POSIX_TIMERS "defined(POSIX_TIMERS)")
   $(if [[ ${WORD_SIZE} = 64 ]]; then
        echo 'printf ("DEFINE ARCH_SIXTYFOUR\n");';
     fi)
 
   $(cpp_test FDATASYNC \
      "defined(_POSIX_SYNCHRONIZED_IO) && _POSIX_SYNCHRONIZED_IO > 0")
+
   return 0;
 }
 EOF

base/core/lib/error.ml

 
 let to_message t = protect (fun () -> Lazy.force t)
 
-let of_message message = lazy message
+let of_message message = Lazy.lazy_from_val message
 
 let sexp_of_t t = Message.sexp_of_t (to_message t)
 
 
 let of_lazy l = lazy (protect (fun () -> String (Lazy.force l)))
 
-let of_string error = lazy (String error)
+let of_string error = Lazy.lazy_from_val (String error)
 
 let of_thunk f = lazy (protect (fun () -> String (f ())))
 

base/core/lib/error.mli

+
 (** Library for lazily constructing error messages.  Error messages are intended to
     be constructed in the following style; for simple errors, you write:
 

base/core/lib/interval.ml

   include Make(Time)
 
   let create_ending_after (open_ofday, close_ofday) ~now =
-    let close_time = Time.ofday_occurrence close_ofday `right_after now in
-    let open_time = Time.ofday_occurrence open_ofday `right_before close_time in
+    let close_time =
+      Time.ofday_occurrence now (Zone.machine_zone ()) close_ofday `right_after
+    in
+    let open_time =
+      Time.ofday_occurrence close_time (Zone.machine_zone ()) open_ofday `right_before
+    in
     create open_time close_time
 
   let create_ending_before (open_ofday, close_ofday) ~ubound =
-    let close_time = Time.ofday_occurrence close_ofday `right_before ubound in
-    let open_time = Time.ofday_occurrence open_ofday `right_before close_time in
+    let close_time =
+      Time.ofday_occurrence ubound (Zone.machine_zone ()) close_ofday `right_before
+    in
+    let open_time =
+      Time.ofday_occurrence close_time (Zone.machine_zone ()) open_ofday `right_before
+    in
     create open_time close_time
 
 end

base/core/lib/linux_ext.ml

   in
   unsafe_sendmsg_nonblocking_no_sigpipe sock iovecs count
 
-
+IFDEF POSIX_TIMERS THEN
 module Clock = struct
   type t
 
   external get_thread_clock :
     unit -> t = "unix_clock_thread_cputime_id_stub"
 end
+ENDIF
 
 external pr_set_pdeathsig : Signal.t -> unit = "linux_pr_set_pdeathsig_stub"
 external pr_get_pdeathsig : unit -> Signal.t = "linux_pr_get_pdeathsig_stub"

base/core/lib/linux_ext.mli

 
 (** {2 Clock functions} *)
 
+IFDEF POSIX_TIMERS THEN
 module Clock : sig
   type t
 
       thread. *)
   val get_thread_clock : unit -> t
 end
+ENDIF
 
 (** {2 Parent death notifications} *)
 

base/core/lib/ocaml_utils_stubs.c

   return v;
 }
 
+#ifndef raise_out_of_memory
+
 void raise_out_of_memory(void)
 {
   value* out_of_memory;
   caml_raise_constant(*out_of_memory);
 }
 
+#endif
+
 void* malloc_exn(size_t size)
 {
   void* ptr = malloc(size);

base/core/lib/ofday.ml

     if is_valid t then Some t else None
 
   let diff t1 t2 =
-    Span.sub (to_span_since_start_of_day t1) (to_span_since_start_of_day t2)
+    Span.(-) (to_span_since_start_of_day t1) (to_span_since_start_of_day t2)
 end
 
 let create ?hr ?min ?sec ?ms ?us () =
         else
           let minute = parse_two_digits str (pos + 3) in
           if minute >= 60 then failwith "minute > 60";
-          let span = Span.add span (Span.of_min (float minute)) in
+          let span = Span.(+) span (Span.of_min (float minute)) in
           if hour = 24 && minute <> 0 then
             failwith "24 hours and non-zero minute";
           if len = 5 then span
           else
             let second = parse_two_digits str (pos + 6) in
             if second >= 60 then failwith "second > 60";
-            let span = Span.add span (Span.of_sec (float second)) in
+            let span = Span.(+) span (Span.of_sec (float second)) in
             if hour = 24 && second <> 0 then
               failwith "24 hours and non-zero seconds";
             if len = 8 then span
                 if hour = 24 && subs <> 0 then
                   failwith "24 hours and non-zero subseconds"
                 else
-                  Span.add span
+                  Span.(+) span
                     (Span.of_sec (float subs /. (10. ** float (len - 9))))
               | _ -> failwith "missing subsecond separator"
         in
 ;;
 
 let sexp_of_t span = Sexp.Atom (to_string span)
+
+let of_float f = T.of_span_since_start_of_day (Span.of_sec f)

base/core/lib/ofday.mli

 (* Represented as a number of seconds since midnight *)
 type t = private float
 
-
 include Binable with type t := t
 include Comparable_binable with type t := t
 include Floatable with type t := t

base/core/lib/option.ml

   | Some _, _ -> x
   | _ -> y
 
+let some_if cond x = if cond then Some x else None
+
 let filter ~f = function
   | Some v as o when f v -> o
   | _ -> None

base/core/lib/option.mli

 
 val first_some : 'a t -> 'a t -> 'a t
 
+val some_if : bool -> 'a -> 'a t
+
 val filter : f:('a -> bool) -> 'a t -> 'a t
 
 (** [try_with f] returns [Some x] if [f] returns [x] and [None] if [f] raises an

base/core/lib/round_robin.ml

-
-open Std_internal
-
-type 'a t =
-  { elements : 'a array;
-    mutable current_idx : int;   (* index of the last considered element *)
-  }
-
-let create elements =
-  if elements = [||]
-  then Error "Elements array is empty"
-  else
-    Ok { elements;
-         current_idx = Array.length elements - 1;
-       }
-
-let elements t = t.elements
-
-(* the S-expression representation is simply the one of the elements array *)
-let t_of_sexp a_of_sexp sexp =
-  Result.failwith_error (create (array_of_sexp a_of_sexp sexp))
-let sexp_of_t sexp_of_a t =
-  sexp_of_array sexp_of_a t.elements
-
-(* move pointer to the next element *)
-let advance_idx t =
-  t.current_idx <- t.current_idx + 1;
-  if t.current_idx = Array.length t.elements then t.current_idx <- 0
-
-let next t =
-  advance_idx t;
-  t.elements.(t.current_idx)
-
-let find_next t ~f =
-  let n = Array.length t.elements in
-  let rec loop num_trials =
-    if num_trials = n
-    then None
-    else
-      let x = next t in
-      if f x
-      then Some x
-      else loop (num_trials + 1)
-  in
-  loop 0

base/core/lib/round_robin.mli

-
-(** A data-structure to loop through a list of values using round-robin *)
-
-type 'a t
-
-include Sexpable.S1 with type 'a t := 'a t
-
-val create : 'a array -> ('a t, string) Result.t
-
-val elements : 'a t -> 'a array
-
-(** Return the next element, round-robin style *)
-val next : 'a t -> 'a
-
-(** Return the next element that satisfies the predicate ~f, or None if all elements
-    failed the test. *)
-val find_next : 'a t -> f:('a -> bool) -> 'a option

base/core/lib/span.ml

 
 module T : sig
   include Constrained_float.S
-  val add     : t -> t -> t
-  val sub     : t -> t -> t
+  val (+)     : t -> t -> t
+  val (-)     : t -> t -> t
   val zero    : t
   val epsilon : t
   val abs     : t -> t
 end = struct
   include (Float : sig
     include Constrained_float.S
-    val add     : t -> t -> t
-    val sub     : t -> t -> t
+    val (+)     : t -> t -> t
+    val (-)     : t -> t -> t
     val zero    : t
     val epsilon : t
     val abs     : t -> t
     ?(ms = 0)
     ?(us = 0)
     () =
-  let (+.) = T.add in
+  let (+) = T.(+) in
   let t =
     of_day    (Float.of_int day)
-    +. of_hr  (Float.of_int hr)
-    +. of_min (Float.of_int min)
-    +. of_sec (Float.of_int sec)
-    +. of_ms  (Float.of_int ms)
-    +. of_us  (Float.of_int us)
+    + of_hr  (Float.of_int hr)
+    + of_min (Float.of_int min)
+    + of_sec (Float.of_int sec)
+    + of_ms  (Float.of_int ms)
+    + of_us  (Float.of_int us)
   in
   match sign with
-  | Float.Sign.Neg -> T.sub T.zero t
+  | Float.Sign.Neg -> T.(-) T.zero t
   | Float.Sign.Pos | Float.Sign.Zero -> t
 
 include T
         | s  -> Float.of_string s
       in
       let len = String.length s in
-      match s.[len - 1] with
+      match s.[Int.(-) len 1] with
       | 's' ->
-        if Int.(>=) len 2 && Char.(=) s.[len - 2] 'm' then of_ms (float 2)
+        if Int.(>=) len 2 && Char.(=) s.[Int.(-) len 2] 'm' then of_ms (float 2)
         else T.of_float (float 1)
       | 'm' -> of_min (float 1)
       | 'h' -> of_hr (float 1)

base/core/lib/span.mli

 val to_day : t -> float
 
 (** {6 Basic operations on spans} *)
-val add   : t -> t -> t
-val sub   : t -> t -> t
+val (+)   : t -> t -> t
+val (-)   : t -> t -> t
 val abs   : t -> t (** absolute value *)
 val scale : t -> float -> t
 val (/)   : t -> float -> t

base/core/lib/std.ml

 module Random = Core_random
 module Result = Result
 module Robustly_comparable = Robustly_comparable
-module Round_robin = Round_robin
 module Set_once = Set_once
 module Sexpable = Sexpable
 module Sexp_maybe = Core_sexp.Sexp_maybe

base/core/lib/time.ml

   match !string_and_sexp_format with
   | `Old | `Force_old -> `Old
   | _ as format -> format
+;;
 
 let modify_string_and_sexp_format =
   let string_and_sexp_format_mutex = Mutex.create () in
     | e ->
       Mutex.unlock string_and_sexp_format_mutex;
       raise e)
+;;
 
 let write_new_string_and_sexp_formats__read_both () =
   modify_string_and_sexp_format (function
       failwith "write_new_string_and_sexp_formats__read_both called after \
         forbid_new_string_and_sexp_formats"
     | _ -> `Write_new_read_both)
+;;
 
 let write_new_string_and_sexp_formats__read_only_new () =
   modify_string_and_sexp_format (function
       failwith "write_new_string_and_sexp_formats__read_only_new called after \
         forbid_new_string_and_sexp_formats"
     | _ -> `Write_new_read_only_new)
+;;
 
 let forbid_new_string_and_sexp_formats () =
   modify_string_and_sexp_format (function
       failwith "use_new_string_and_sexp_formats called before \
         forbid_new_string_and_sexp_formats"
   )
-
+;;
 
 let to_epoch t = T.to_float t
 
     }
   in
   (cache, (date, ofday))
+;;
 
 (* A thin caching layer over the actual of_epoch (of_epoch_internal just above) used only
    to gain some speed when we translate the same time/date over and over again *)
       cache := new_cache;
       r
     end)
+;;
 
 let to_date_ofday time zone =
   try
     of_epoch zone (to_epoch time)
   with
   | Unix.Unix_error(_, "gmtime", _) -> raise (Invalid_argument "Time.to_date_ofday")
+;;
 
 let of_date_ofday zone date ofday =
   let module P = Span.Parts in
     Zone.shift_epoch_time zone `Local epoch
   in
   T.of_float time
+;;
 
 let to_local_date_ofday t          = to_date_ofday t (Zone.machine_zone ())
 let of_local_date_ofday date ofday = of_date_ofday (Zone.machine_zone ()) date ofday
   let epoch     = to_epoch t in
   let utc_epoch = Zone.shift_epoch_time zone `UTC epoch in
   Span.of_sec (utc_epoch -. epoch)
+;;
 
 let to_string_abs ?(zone=Zone.machine_zone ()) time =
   let date, ofday  = to_date_ofday time zone in
         (if Span.(<) utc_offset Span.zero then "-" else "+");
         Ofday.to_string_trimmed (Ofday.of_span_since_start_of_day (Span.abs utc_offset))
       ]))
+;;
 
 let to_string_trimmed t =
   let date, sec = to_local_date_ofday t in
   (Date.to_string date) ^ " " ^ (Ofday.to_string_trimmed sec)
+;;
 
 let to_sec_string t =
   let date, sec = to_local_date_ofday t in
   (Date.to_string date) ^ " " ^ (Ofday.to_sec_string sec)
+;;
 
 let to_filename_string t =
   let date, ofday = to_local_date_ofday t in
   (Date.to_string date) ^ "_" ^
     (String.tr ~target:':' ~replacement:'-' (Ofday.to_string ofday))
+;;
 
 let to_string_fix_proto utc t =
   let date, sec =
     | `Local -> to_local_date_ofday t
   in
   (Date.to_string_iso8601_basic date) ^ "-" ^ (Ofday.to_millisec_string sec)
+;;
 
 let of_string_fix_proto utc str =
   try
       (Ofday.of_string_iso8601_extended str ~pos:(expect_dash + 1))
   with exn ->
     invalid_argf "Time.of_string_fix_proto %s: %s" str (Exn.to_string exn) ()
+;;
 
 let of_filename_string s =
   try
   with
   | exn ->
       invalid_argf "Time.of_filename_string (%s): %s" s (Exn.to_string exn) ()
-
-let of_date_time_strings date_string time_string =
-  of_local_date_ofday (Date.of_string date_string) (Ofday.of_string time_string)
-
-let of_date_time_strings_utc date_string time_string =
-  of_date_ofday Zone.utc (Date.of_string date_string) (Ofday.of_string time_string)
+;;
 
 let format t s = Unix.strftime (to_tm t) s
 
   match pause_for span with
   | `Remaining span -> pause span
   | `Ok -> ()
+;;
 
 (** Pause but allow events to interrupt. *)
 let interruptible_pause = pause_for
 let rec pause_forever () =
   pause (Span.of_day 1.0);
   pause_forever ()
+;;
 
-let ofday_occurrence_gen ~utc = ();
-  fun ofday before_or_after time ->
-    let first_guess =
-      if utc then
-        of_date_ofday Zone.utc (fst (to_date_ofday time Zone.utc)) ofday
-      else
-        of_local_date_ofday (to_local_date time) ofday
-    in
-    match before_or_after with
-    | `right_before ->
-        if T.(<) first_guess time
-        then first_guess
-        else T.sub first_guess Span.day
-    | `right_after ->
-        if T.(>) first_guess time
-        then first_guess
-        else T.add first_guess Span.day
-
-let ofday_occurrence = ofday_occurrence_gen ~utc:false
-let ofday_occurrence_utc = ofday_occurrence_gen ~utc:true
+let ofday_occurrence t zone ofday before_or_after =
+  let first_guess =
+    of_date_ofday zone (fst (to_date_ofday t zone)) ofday
+  in
+  match before_or_after with
+  | `right_before ->
+      if T.(<) first_guess t
+      then first_guess
+      else T.sub first_guess Span.day
+  | `right_after ->
+      if T.(>) first_guess t
+      then first_guess
+      else T.add first_guess Span.day
+;;
 
 let epoch = T.of_float 0.0
 
 let to_string_deprecated t =
   let date, sec = to_local_date_ofday t in
   String.concat [Date.to_string date; " "; Ofday.to_string sec]
+;;
 
 let to_string t =
   match !string_and_sexp_format with
   | `Write_new_read_both
   | `Write_new_read_only_new -> to_string_abs t
   | `Old | `Force_old -> to_string_deprecated t
+;;
 
 exception Time_of_string of string * Exn.t with sexp
 exception Time_string_not_absolute of string with sexp
         of_float (to_float (of_date_ofday Zone.utc date ofday) -. utc_offset)
   with
   | e -> raise (Time_of_string (s,e))
+;;
 
 let of_string_abs s = of_string_gen ~require_absolute:true s
 let of_string s =
     | `Old | `Force_old | `Write_new_read_both -> false
   in
   of_string_gen s ~require_absolute
+;;
 
 let t_of_sexp sexp = match sexp with
   | Sexp.List [Sexp.Atom date; Sexp.Atom ofday; (Sexp.Atom "UTC" | Sexp.Atom "utc")] ->
       | e -> of_sexp_error (sprintf "Time.t_of_sexp: %s" (Exn.to_string e)) sexp
       end
   | _ -> of_sexp_error "Time.t_of_sexp" sexp
+;;
 
 let sexp_of_t t =
   match String.lsplit2 (to_string t) ~on:' ' with
       Sexp.List [Sexp.Atom date; Sexp.Atom ofday]
   | None ->
       raise (Bug "Time.sexp_of_t: unexpected None")
+;;
 
 let pp ppf t = Format.fprintf ppf "%s" (to_string t)
 let () = Pretty_printer.register "Core.Time.pp"
 let to_localized_string time zone =
   let date,ofday = to_date_ofday time zone in
   String.concat [Date.to_string date; " "; Ofday.to_string ofday]
+;;
 
 let of_localized_string zone str =
   try
       of_date_ofday zone date ofday
   with e ->
     Exn.reraise e "Time.of_localstring"
+;;
+

base/core/lib/time.mli

 
 val of_string_abs : string -> t