Improve OCaml 5 compatibility

Makefile

@@ -2,6 +2,11 @@ DUNE 	= dune
 JOBS    = $(shell getconf _NPROCESSORS_ONLN)
 PROFILE = release
 
+# K&R style indentation, could use in format target below
+INDENT += -nbad -bap -nbc -br -brs -c33 -cd33 -ncdb -ce -ci4 -cli0
+INDENT += -d0 -di1 -nfc1 -i4 -ip0 -l75 -lp -npcs
+INDENT += -npsl -nsc -nsob
+
 .PHONY: build check test clean format install
 
 build:

mmap/xenmmap_stubs.c

@@ -30,6 +30,7 @@
 #include <caml/fail.h>
 #include <caml/callback.h>
 #include <caml/unixsupport.h>
+#include <caml/threads.h>
 
 #define Intf_val(a) ((struct mmap_interface *)Data_abstract_val(a))
 #define Wsize_bsize_round(n) (Wsize_bsize( (n) + sizeof(value) - 1 ))
@@ -89,10 +90,15 @@ stub_mmap_init (value fd, value pflag, value mflag, value len, value offset)
                 caml_invalid_argument ("negative size");
         if (Int_val (offset) < 0)
                 caml_invalid_argument ("negative offset");
-        length = Int_val (len);
+        length = Long_val (len);
+
+        int c_fd = Int_val (fd);
+        size_t c_offset = Long_val (offset);
+
+        caml_release_runtime_system ();
+        addr = mmap (NULL, length, c_pflag, c_mflag, c_fd, c_offset);
+        caml_acquire_runtime_system ();
 
-        addr = mmap (NULL, length, c_pflag, c_mflag, Int_val (fd),
-                     Int_val (offset));
         if (MAP_FAILED == addr)
                 uerror ("mmap", Nothing);
 
@@ -104,9 +110,16 @@ CAMLprim value
 stub_mmap_final (value intf)
 {
         CAMLparam1 (intf);
+        void *addr = Intf_val (intf)->addr;
+
+        if (addr != MAP_FAILED)
+          {
+                  int len = Intf_val (intf)->len;
+                  caml_release_runtime_system ();
+                  munmap (addr, len);
+                  caml_acquire_runtime_system ();
+          }
 
-        if (Intf_val (intf)->addr != MAP_FAILED)
-                munmap (Intf_val (intf)->addr, Intf_val (intf)->len);
         Intf_val (intf)->addr = MAP_FAILED;
 
         CAMLreturn (Val_unit);

ocaml-evtchn/lib/eventchn_stubs.c

@@ -32,86 +32,128 @@
 #include <caml/custom.h>
 #include <caml/callback.h>
 #include <caml/fail.h>
+#include <caml/threads.h>
 
-#define _H(__h) ((xenevtchn_handle *)(__h))
-#define XENEVTCHN_NO_CLOEXEC (1 << 0)
+static inline xenevtchn_handle *
+xce_of_val (value v)
+{
+        return *(xenevtchn_handle **) Data_custom_val (v);
+}
+
+static void
+stub_evtchn_finalize (value v)
+{
+        xenevtchn_close (xce_of_val (v));
+}
 
-xenevtchn_handle *global_xce = NULL;
+static struct custom_operations xenevtchn_ops = {
+        .identifier = "xenevtchn",
+        .finalize = stub_evtchn_finalize,
+        .compare = custom_compare_default,      /* Can't compare */
+        .hash = custom_hash_default,    /* Can't hash */
+        .serialize = custom_serialize_default,  /* Can't serialize */
+        .deserialize = custom_deserialize_default,      /* Can't deserialize */
+        .compare_ext = custom_compare_ext_default,      /* Can't compare */
+};
 
 CAMLprim value
 stub_evtchn_init (value cloexec)
 {
         CAMLparam1 (cloexec);
+        CAMLlocal1 (result);
+        xenevtchn_handle *xce;
         unsigned int flags = 0;
+
         if (!Bool_val (cloexec))
                 flags |= XENEVTCHN_NO_CLOEXEC;
 
-        if (global_xce == NULL)
+        result = caml_alloc_custom (&xenevtchn_ops, sizeof (xce), 0, 1);
+
+        caml_release_runtime_system ();
+        xce = xenevtchn_open (NULL, flags);
+        caml_acquire_runtime_system ();
+
+        if (xce == NULL)
           {
-                  global_xce = xenevtchn_open (NULL, flags);
+                  caml_failwith (strerror (errno));
           }
 
-        if (global_xce == NULL)
-                caml_failwith (strerror (errno));
-
-        CAMLreturn ((value) global_xce);
+        *(xenevtchn_handle **) Data_custom_val (result) = xce;
+        CAMLreturn (result);
 }
 
 CAMLprim value
-stub_evtchn_fd (value xce)
+stub_evtchn_fd (value xce_val)
 {
-        CAMLparam1 (xce);
+        CAMLparam1 (xce_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
         int fd;
 
-        fd = xenevtchn_fd (_H (xce));
+        /* Don't drop the GC lock.  This is a simple read out of memory */
+        fd = xenevtchn_fd (xce);
         if (fd == -1)
           {
-                  perror ("xc_evtchn_fd");
                   caml_failwith (strerror (errno));
           }
+
         CAMLreturn (Val_int (fd));
 }
 
 CAMLprim value
-stub_evtchn_notify (value xce, value port)
+stub_evtchn_notify (value xce_val, value port_val)
 {
-        CAMLparam2 (xce, port);
-        if (xenevtchn_notify (_H (xce), Int_val (port)) == -1)
+        CAMLparam2 (xce_val, port_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
+        int rc;
+        int port = Int_val (port_val);
+
+        caml_release_runtime_system ();
+        rc = xenevtchn_notify (xce, port);
+        caml_acquire_runtime_system ();
+
+        if (rc == -1)
           {
-                  perror ("xc_evtchn_notify");
                   caml_failwith (strerror (errno));
           }
 
         CAMLreturn (Val_unit);
 }
 
 CAMLprim value
-stub_evtchn_bind_interdomain (value xce, value domid, value remote_port)
+stub_evtchn_bind_interdomain (value xce_val, value domid_val,
+                              value remote_port_val)
 {
-        CAMLparam3 (xce, domid, remote_port);
+        CAMLparam3 (xce_val, domid_val, remote_port_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
         xenevtchn_port_or_error_t rc;
+        int domid = Int_val (domid_val);
+        int remote_port = Int_val (remote_port_val);
+
+        caml_release_runtime_system ();
+        rc = xenevtchn_bind_interdomain (xce, domid, remote_port);
+        caml_acquire_runtime_system ();
 
-        rc = xenevtchn_bind_interdomain (_H (xce), Int_val (domid),
-                                         Int_val (remote_port));
         if (rc == -1)
           {
-                  perror ("xc_evtchn_bind_interdomain");
                   caml_failwith (strerror (errno));
           }
 
         CAMLreturn (Val_int (rc));
 }
 
 CAMLprim value
-stub_evtchn_alloc_unbound (value xce, value remote_domid)
+stub_evtchn_alloc_unbound (value xce_val, value remote_domid_val)
 {
-        CAMLparam2 (xce, remote_domid);
+        CAMLparam2 (xce_val, remote_domid_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
         xenevtchn_port_or_error_t rc;
+        int remote_domid = Int_val (remote_domid_val);
 
-        rc = xenevtchn_bind_unbound_port (_H (xce), Int_val (remote_domid));
+        caml_release_runtime_system ();
+        rc = xenevtchn_bind_unbound_port (xce, remote_domid);
+        caml_acquire_runtime_system ();
         if (rc == -1)
           {
-                  perror ("xc_evtchn_bind_unbound_port");
                   caml_failwith (strerror (errno));
           }
 
@@ -127,47 +169,58 @@ stub_evtchn_virq_dom_exc (value unit)
 }
 
 CAMLprim value
-stub_evtchn_bind_virq (value xce, value virq)
+stub_evtchn_bind_virq (value xce_val, value virq_val)
 {
-        CAMLparam2 (xce, virq);
+        CAMLparam2 (xce_val, virq_val);
         xenevtchn_port_or_error_t rc;
+        xenevtchn_handle *xce = xce_of_val (xce_val);
+        int virq = Int_val (virq_val);
 
-        rc = xenevtchn_bind_virq (_H (xce), Int_val (virq));
+        caml_release_runtime_system ();
+        rc = xenevtchn_bind_virq (xce, virq);
+        caml_acquire_runtime_system ();
         if (rc == -1)
           {
-                  perror ("xc_evtchn_bind_virq");
                   caml_failwith (strerror (errno));
           }
 
         CAMLreturn (Val_int (rc));
 }
 
 CAMLprim value
-stub_evtchn_unbind (value xce, value port)
+stub_evtchn_unbind (value xce_val, value port_val)
 {
-        CAMLparam2 (xce, port);
-        if (xenevtchn_unbind (_H (xce), Int_val (port)) == -1)
+        CAMLparam2 (xce_val, port_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
+        int port = Int_val (port_val);
+        int rc;
+
+        caml_release_runtime_system ();
+        rc = xenevtchn_unbind (xce, port);
+        caml_acquire_runtime_system ();
+        if (rc == -1)
           {
-                  perror ("xc_evtchn_unbind");
                   caml_failwith (strerror (errno));
           }
 
         CAMLreturn (Val_unit);
 }
 
 CAMLprim value
-stub_evtchn_pending (value xce)
+stub_evtchn_pending (value xce_val)
 {
-        CAMLparam1 (xce);
+        CAMLparam1 (xce_val);
         CAMLlocal1 (generation);
         xenevtchn_port_or_error_t port;
+        xenevtchn_handle *xce = xce_of_val (xce_val);
 
         generation = caml_alloc_tuple (2);
 
-        port = xenevtchn_pending (_H (xce));
+        caml_release_runtime_system ();
+        port = xenevtchn_pending (xce);
+        caml_acquire_runtime_system ();
         if (port == -1)
           {
-                  perror ("xc_evtchn_pending");
                   caml_failwith (strerror (errno));
           }
 
@@ -178,12 +231,18 @@ stub_evtchn_pending (value xce)
 }
 
 CAMLprim value
-stub_evtchn_unmask (value xce, value port)
+stub_evtchn_unmask (value xce_val, value port_val)
 {
-        CAMLparam2 (xce, port);
-        if (xenevtchn_unmask (_H (xce), Int_val (port)) == -1)
+        CAMLparam2 (xce_val, port_val);
+        xenevtchn_handle *xce = xce_of_val (xce_val);
+        int port = Int_val (port_val);
+        int rc;
+
+        caml_release_runtime_system ();
+        rc = xenevtchn_unmask (xce, port);
+        caml_acquire_runtime_system ();
+        if (rc == -1)
           {
-                  perror ("xc_evtchn_unmask");
                   caml_failwith (strerror (errno));
           }
 

oxenstored/config.ml

@@ -65,7 +65,9 @@ let parse_line stream =
     try
       let line = trim_spaces (input_line stream) in
       if String.length line > 0 && line.[0] <> '#' then
-        match to_config line with
+        match
+          to_config line
+        with
         | None ->
             read_filter_line ()
         | Some x ->

oxenstored/connection.ml

@@ -433,10 +433,9 @@ let lookup_watch_perm path = function
     try
       Store.Path.apply root path @@ fun parent name ->
       Store.Node.get_perms parent
-      ::
-      ( try [Store.Node.get_perms (Store.Node.find parent name)]
-        with Not_found -> []
-      )
+      :: ( try [Store.Node.get_perms (Store.Node.find parent name)]
+           with Not_found -> []
+        )
     with Define.Invalid_path | Not_found -> []
   )
 
@@ -491,7 +490,9 @@ let fire_single_watch source (oldroot, root) depth watch =
     if watch.path.[0] = '@' then
       true
     else
-      match watch.depth with
+      match
+        watch.depth
+      with
       | None ->
           true
       | Some x when x >= depth - watch.path_depth ->
@@ -523,14 +524,14 @@ let fire_watch source roots watch path depth =
 (* Search for a valid unused transaction id. *)
 let rec valid_transaction_id con proposed_id =
   (*
-	 * Clip proposed_id to the range [1, 0x3ffffffe]
-	 *
-	 * The chosen id must not trucate when written into the uint32_t tx_id
-	 * field, and needs to fit within the positive range of a 31 bit ocaml
-	 * integer to function when compiled as 32bit.
-	 *
-	 * Oxenstored therefore supports only 1 billion open transactions.
-	 *)
+   * Clip proposed_id to the range [1, 0x3ffffffe]
+   *
+   * The chosen id must not trucate when written into the uint32_t tx_id
+   * field, and needs to fit within the positive range of a 31 bit ocaml
+   * integer to function when compiled as 32bit.
+   *
+   * Oxenstored therefore supports only 1 billion open transactions.
+   *)
   let id =
     if proposed_id <= 0 || proposed_id >= 0x3fffffff then 1 else proposed_id
   in

oxenstored/connections.ml

@@ -178,7 +178,9 @@ let add_watch cons con path token depth =
   ( if is_special_watch then
       (* No depth can be specified for @releaseDomain/domid watches.
          Only depth=1 can be specified for other special watches *)
-      match depth with
+        match
+          depth
+        with
       | Some _ when String.starts_with ~prefix:"@releaseDomain/" apath ->
           raise
             (Invalid_argument

oxenstored/domains.ml

@@ -24,7 +24,9 @@ let load_plug fname =
   let fail_with fmt = Printf.ksprintf failwith fmt in
   let fname = Dynlink.adapt_filename fname in
   if Sys.file_exists fname then
-    try Dynlink.loadfile fname with
+    try
+      Dynlink.loadfile fname
+    with
     | Dynlink.Error err as e ->
         error "ERROR loading plugin '%s': %s\n%!" fname
           (Dynlink.error_message err) ;