Experimental work on an OCaml poll() wrapper

OMakefile

@@ -1,16 +1,18 @@
-USE_OCAMLFIND = true
 OCAMLPACKS[] = 
     equeue
     pcre
     str
-NATIVE_ENABLED = true
-BYTE_ENABLED = true
 OCAMLCFLAGS += -g
 
 .DEFAULT: ircd
 
 OCamlProgram(ircd, ircd irc command iobuf client channel)
 
+section
+    OCAML_CLIBS = ocamlpoll
+    StaticCLibrary(ocamlpoll, inspect poll_stubs)
+    OCamlProgram(polltest, polltest)
+
 section
     OCAMLPACKS[] +=
         oUnit
@@ -23,6 +25,10 @@ section
 
     OCamlProgram(tests, tests chat irc command iobuf client channel)
 
+.PHONY: test
+test: tests
+	./tests
+
 .PHONY: clean
 clean:
 	rm $(filter-proper-targets $(ls R, .))

OMakeroot

@@ -1,37 +1,9 @@
-########################################################################
+open build/C
-# Permission is hereby granted, free of charge, to any person
-# obtaining a copy of this file, to deal in the File without
-# restriction, including without limitation the rights to use,
-# copy, modify, merge, publish, distribute, sublicense, and/or
-# sell copies of the File, and to permit persons to whom the
-# File is furnished to do so, subject to the following condition:
-#
-# THE FILE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
-# DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
-# OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE FILE OR
-# THE USE OR OTHER DEALINGS IN THE FILE.
-
-########################################################################
-# The standard OMakeroot file.
-# You will not normally need to modify this file.
-# By default, your changes should be placed in the
-# OMakefile in this directory.
-#
-# If you decide to modify this file, note that it uses exactly
-# the same syntax as the OMakefile.
-#
-
-#
-# Include the standard installed configuration files.
-# Any of these can be deleted if you are not using them,
-# but you probably want to keep the Common file.
-#
-#open build/C
 open build/OCaml
-#open build/LaTeX
+
+USE_OCAMLFIND = true
+NATIVE_ENABLED = true
+BYTE_ENABLED = true
 
 #
 # The command-line variables are defined *after* the

inspect.c

@@ -0,0 +1,53 @@
+#include <stdio.h>
+#include <caml/mlvalues.h>
+
+void
+margin (int n)
+{
+  while (n-- > 0)
+    printf(".");
+  return;
+}
+
+void
+print_block(value v,int m)
+{
+  int size, i;
+  margin(m);
+  if (Is_long(v))
+    { printf("immediate value (%d)\n", Long_val(v));  return; };
+  printf ("memory block: size=%d  -  ", size=Wosize_val(v));
+  switch (Tag_val(v))
+   {
+    case Closure_tag :
+        printf("closure with %d free variables\n", size-1);
+        margin(m+4); printf("code pointer: %p\n",Code_val(v)) ;
+        for (i=1;i<size;i++)  print_block(Field(v,i), m+4);
+        break;
+    case String_tag :
+        printf("string: %s (%s)\n", String_val(v),(char *) v);
+        break;
+    case Double_tag:
+        printf("float: %g\n", Double_val(v));
+        break;
+    case Double_array_tag :
+        printf ("float array: ");
+        for (i=0;i<size/Double_wosize;i++)  printf("  %g", Double_field(v,i));
+        printf("\n");
+        break;
+    case Abstract_tag : printf("abstract type\n"); break;
+    default:
+        if (Tag_val(v)>=No_scan_tag) { printf("unknown tag"); break; };
+        printf("structured block (tag=%d):\n",Tag_val(v));
+        for (i=0;i<size;i++)  print_block(Field(v,i),m+4);
+   }
+  return ;
+}
+
+value
+inspect_block (value v)
+{
+  print_block(v,4);
+  fflush(stdout);
+  return v;
+}

poll.mli

@@ -0,0 +1,5 @@
+type pollfd = {fd: int;
+               events: int;
+               revents: int}
+
+external in : int = "poll_in"

poll_stubs.c

@@ -0,0 +1,150 @@
+#include <caml/mlvalues.h>
+#include <caml/fail.h>
+#include <caml/custom.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+
+#include <string.h>
+#include <errno.h>
+#include <poll.h>
+#include <stdlib.h>
+
+#define puke(str)                                                       \
+  {                                                                     \
+    char errstr[512];                                                   \
+    snprintf(errstr, sizeof(errstr), str ": %s", strerror(errno));      \
+    caml_failwith(errstr);                                              \
+  }
+
+value inspect_block(value v);
+
+enum {
+  caml_POLLIN,
+  caml_POLLPRI,
+  caml_POLLOUT,
+  caml_POLLERR,
+  caml_POLLHUP,
+  caml_POLLNVAL
+}
+
+static int
+list_length(value list)
+{
+  int   len;
+  value l;
+
+  for (l = list; l != Val_int(0); l = Field(l, 1)) {
+    len += 1;
+  }
+  return len;
+}
+
+static int
+int_of_event_list(value list)
+{
+  int   acc = 0;
+  value l;
+
+  for (l = list; l != Val_int(0); l = Field(l, 1)) {
+    switch (Field(l, 0)) {
+      case caml_POLLIN:
+        acc |= POLLIN;
+        break;
+      case caml_POLLPRI:
+        acc |= POLLPRI;
+        break;
+      case caml_POLLOUT:
+        acc |= POLLOUT;
+        break;
+      case caml_POLLERR:
+        acc |= POLLERR;
+        break;
+      case caml_POLLHUP:
+        acc |= POLLHUP;
+        break;
+      case caml_POLLNVAL:
+        acc |= POLLNVAL;
+        break;
+    }
+  }
+  return acc;
+}
+
+static value
+append(value list, value item)
+{
+  value new = alloc_small(2, 0);
+  Field(new, 0) = item;
+  Field(new, 1) = list;
+  return new;
+}
+
+static value
+event_list_of_int(int events)
+{
+  value result = Val_int(0);
+
+  if (events & POLLIN) {
+    result = append(result, Val_int(caml_POLLIN));
+  } else if (events & POLLPRI) {
+    result = append(result, Val_int(caml_POLLPRI));
+  } else if (events & POLLOUT) {
+    result = append(result, Val_int(caml_POLLOUT));
+  } else if (events & POLLERR) {
+    result = append(result, Val_int(caml_POLLERR));
+  } else if (events & POLLHUP) {
+    result = append(result, Val_int(caml_POLLHUP));
+  } else if (events & POLLNVAL) {
+    result = append(result, Val_int(caml_POLLNVAL));
+  }
+  return result;
+}
+
+CAMLprim value
+ocaml_poll(value caml_fds, value caml_timeout)
+{
+  CAMLparam2(caml_fds, caml_timeout);
+  CAMLlocal1(result);
+
+  value         l;
+  int           nfds;
+  int           timeout = Int_val(caml_timeout);
+  struct pollfd fds[nfds];
+  int           i;
+  int           ret;
+
+  result = Val_int(0);
+  inspect_block(caml_fds);
+
+  /* Count entries */
+  nfds = list_length(caml_fds);
+
+  /* Build fds */
+  for (i=0, l = caml_fds; l != Val_int(0); i += 1, l = Field(l, 1)) {
+    value f = Field(l, 0);
+    struct pollfd *p = &(fds[i]);
+
+    p->fd = Int_val(Field(f, 0));
+    p->events = int_of_event_list(Field(f, 1));
+  }
+
+  /* Call poll */
+  ret = poll(*fds, nfds, timeout);
+  if (-1 == ret) {
+    puke("poll");
+  }
+
+  for (i=0; i < nfds; i += 1) {
+    struct pollfd *p = &(fds[i]);
+    if (p->revents) {
+      value v = alloc_small(2,0);
+
+      Field(v, 0) = Val_int(p->fd);
+      Field(v, 1) = event_list_of_int(p->revents);
+      result = append(result, v);
+    }
+  }
+
+  CAMLreturn(result);
+}
+

polltest.ml

@@ -0,0 +1,9 @@
+external poll : 'a -> 'b -> 'c = "ocaml_poll"
+
+type event = POLLIN | POLLPRI | POLLOUT | POLLERR | POLLHUP | POLLNVAL
+
+let _ =
+  poll [
+    (10, [POLLIN; POLLOUT]);
+    (20, [POLLOUT])
+  ] ()