add (fibers epoll)

* configure.ac: Add checks for sys/epoll.h, epoll_create, and
  epoll_create1.
* epoll.c: New file.
* module/ice-9/epoll.scm: New file.
* module/Makefile.am: Build new files.
* env.in: Add to LTDL_LIBRARY_PATH.
* .gitignore: Add new built products.

6 files changed, 311 insertions, 5 deletions

diff --git a/.gitignore b/.gitignore
index 1b51d3d..ddcf535 100644
--- a/.gitignore
+++ b/.gitignore
@@ -20,3 +20,9 @@
 /libtool
 /stamp-h1
 /m4
+/.deps
+/.libs
+/build-aux/depcomp
+/epoll.la
+/epoll_la-epoll.lo
+*.go
diff --git a/Makefile.am b/Makefile.am
index 6f5b870..2fd2ec8 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -15,19 +15,24 @@
 # License along with this program.  If not, see
 # <http://www.gnu.org/licenses/>.
 
+ACLOCAL_AMFLAGS = -I m4
+
 include build-aux/guile.am
 
 moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
 godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/ccache
 
-ACLOCAL_AMFLAGS = -I m4
+SOURCES = fibers/epoll.scm
 
-SOURCES =
-
-# info_TEXINFOS = doc/guile-present.texi
+extlibdir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/extensions
+extlib_LTLIBRARIES = epoll.la
+AM_CFLAGS = -I$(srcdir) $(WARN_CFLAGS) $(DEBUG_CFLAGS)
+epoll_la_SOURCES = epoll.c
+epoll_la_CFLAGS = $(AM_CFLAGS) $(GUILE_CFLAGS)
+epoll_la_LIBADD = $(GUILE_LIBS)
+epoll_la_LDFLAGS = -export-dynamic -module
 
 # TESTS=tests/org-mode.scm
-
 # TESTS_ENVIRONMENT=top_srcdir="$(abs_top_srcdir)" ./env guile -s
 
 EXTRA_DIST += \
diff --git a/configure.ac b/configure.ac
index dc688ef..314ab23 100644
--- a/configure.ac
+++ b/configure.ac
@@ -34,6 +34,9 @@ AC_PROG_CC
 AC_STDC_HEADERS
 AC_PROG_LIBTOOL
 
+AC_CHECK_HEADERS([sys/epoll.h])
+AC_CHECK_FUNCS([epoll_create epoll_create1])
+
 WARN_CFLAGS=-Wall
 AC_ARG_ENABLE([Werror], AC_HELP_STRING([--disable-Werror],[Don't stop the build on errors]),
         [], WARN_CFLAGS="-Wall -Werror")
diff --git a/env.in b/env.in
index 21cc2dc..54d837d 100644
--- a/env.in
+++ b/env.in
@@ -33,6 +33,12 @@ else
   GUILE_LOAD_COMPILED_PATH=@abs_top_builddir@:$GUILE_LOAD_COMPILED_PATH
 fi
 
+if test "$LTDL_LIBRARY_PATH" = ""; then
+  LTDL_LIBRARY_PATH=@abs_top_builddir@/.libs
+else
+  LTDL_LIBRARY_PATH=@abs_top_builddir@/.libs:$LTDL_LIBRARY_PATH
+fi
+
 if test "$PATH" = ""; then
   PATH="@abs_top_srcdir@/bin"
 else
@@ -41,6 +47,7 @@ fi
 
 export GUILE_LOAD_PATH
 export GUILE_LOAD_COMPILED_PATH
+export LTDL_LIBRARY_PATH
 export PATH
 
 exec "$@"
diff --git a/epoll.c b/epoll.c
new file mode 100644
index 0000000..1b6651a
--- /dev/null
+++ b/epoll.c
@@ -0,0 +1,174 @@
+/* Copyright (C) 2016 Andy Wingo <wingo@pobox.com>
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+
+#define _GNU_SOURCE
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+#include <sys/epoll.h>
+#include <libguile.h>
+
+/* {EPoll}
+ */
+
+/* EPoll is a newer Linux interface designed for sets of file
+   descriptors that are mostly in a dormant state.  These primitives
+   wrap the epoll interface on a very low level.
+
+   This is a low-level interface.  See the `(fibers epoll)' module for
+   a more usable wrapper.  Note that this low-level interface deals in
+   file descriptors, not ports, in order to allow higher-level code to
+   handle the interaction with the garbage collector.  */
+static SCM
+scm_primitive_epoll_create (SCM cloexec_p)
+#define FUNC_NAME "epoll-create"
+{
+  int fd;
+
+#ifdef HAVE_EPOLL_CREATE1
+  fd = epoll_create1 (scm_is_true (cloexec_p) ? EPOLL_CLOEXEC : 0);
+  if (fd < 0)
+    SCM_SYSERROR;
+#else
+  fd = epoll_create (16);
+  if (fd < 0)
+    SCM_SYSERROR;
+  if (scm_is_true (cloexec_p))
+    fcntl (fd, F_SETFD, FD_CLOEXEC, 1);
+#endif
+
+  return scm_from_int (fd);
+}
+#undef FUNC_NAME
+
+/* This epoll wrapper always places the fd itself as the "data" of the
+   events structure.  */
+static SCM
+scm_primitive_epoll_ctl (SCM epfd, SCM op, SCM fd, SCM events)
+#define FUNC_NAME "primitive-epoll-ctl"
+{
+  int c_epfd, c_op, c_fd;
+  struct epoll_event ev = { 0, };
+
+  c_epfd = scm_to_int (epfd);
+  c_op = scm_to_int (op);
+  c_fd = scm_to_int (fd);
+
+  if (SCM_UNBNDP (events))
+    {
+      if (c_op == EPOLL_CTL_DEL)
+        /* Events do not matter in this case.  */
+        ev.events = 0;
+      else
+        SCM_MISC_ERROR ("missing events arg", SCM_EOL);
+    }
+  else
+    ev.events = scm_to_uint32 (events);
+
+  ev.data.fd = c_fd;
+
+  if (epoll_ctl (c_epfd, c_op, c_fd, &ev))
+    SCM_SYSERROR;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Wait on the files whose descriptors were registered on EPFD, and
+   write the resulting events in EVENTSV, a bytevector.  Returns the
+   number of struct epoll_event values that were written to EVENTSV,
+   which may be zero if no files triggered wakeups within TIMEOUT
+   milliseconds.  */
+static SCM
+scm_primitive_epoll_wait (SCM epfd, SCM eventsv, SCM timeout)
+#define FUNC_NAME "primitive-epoll-wait"
+{
+  int c_epfd, maxevents, rv, c_timeout;
+  struct epoll_event *events;
+
+  c_epfd = scm_to_int (epfd);
+
+  SCM_VALIDATE_BYTEVECTOR (SCM_ARG2, eventsv);
+  if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (eventsv) % sizeof (*events)))
+    SCM_OUT_OF_RANGE (SCM_ARG2, eventsv);
+
+  events = (struct epoll_event *) SCM_BYTEVECTOR_CONTENTS (eventsv);
+  maxevents = SCM_BYTEVECTOR_LENGTH (eventsv) / sizeof (*events);
+  c_timeout = SCM_UNBNDP (timeout) ? -1 : scm_to_int (timeout);
+
+ retry:
+  rv = epoll_wait (c_epfd, events, maxevents, c_timeout);
+  if (rv == -1)
+    {
+      if (errno == EINTR)
+        {
+          scm_async_tick ();
+          goto retry;
+        }
+      SCM_SYSERROR;
+    }
+
+  return scm_from_int (rv);
+}
+#undef FUNC_NAME
+
+
+
+
+/* Low-level helpers for (fibers poll).  */
+void
+init_fibers_epoll (void)
+{
+  scm_c_define_gsubr ("primitive-epoll-create", 1, 0, 0,
+                      scm_primitive_epoll_create);
+  scm_c_define_gsubr ("primitive-epoll-ctl", 3, 1, 0,
+                      scm_primitive_epoll_ctl);
+  scm_c_define_gsubr ("primitive-epoll-wait", 3, 1, 0,
+                      scm_primitive_epoll_wait);
+  scm_c_define ("%sizeof-struct-epoll-event",
+                scm_from_size_t (sizeof (struct epoll_event)));
+  scm_c_define ("%offsetof-struct-epoll-event-fd",
+                scm_from_size_t (offsetof (struct epoll_event, data.fd)));
+  scm_c_define ("EPOLLIN", scm_from_int (EPOLLIN));
+  scm_c_define ("EPOLLOUT", scm_from_int (EPOLLOUT));
+#ifdef EPOLLRDHUP
+  scm_c_define ("EPOLLRDHUP", scm_from_int (EPOLLRDHUP));
+#endif
+  scm_c_define ("EPOLLPRI", scm_from_int (EPOLLPRI));
+  scm_c_define ("EPOLLERR", scm_from_int (EPOLLERR));
+  scm_c_define ("EPOLLHUP", scm_from_int (EPOLLHUP));
+  scm_c_define ("EPOLLET", scm_from_int (EPOLLET));
+#ifdef EPOLLONESHOT
+  scm_c_define ("EPOLLONESHOT", scm_from_int (EPOLLONESHOT));
+#endif
+  scm_c_define ("EPOLL_CTL_ADD", scm_from_int (EPOLL_CTL_ADD));
+  scm_c_define ("EPOLL_CTL_MOD", scm_from_int (EPOLL_CTL_MOD));
+  scm_c_define ("EPOLL_CTL_DEL", scm_from_int (EPOLL_CTL_DEL));
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/
diff --git a/fibers/epoll.scm b/fibers/epoll.scm
new file mode 100644
index 0000000..356c778
--- /dev/null
+++ b/fibers/epoll.scm
@@ -0,0 +1,111 @@
+;; epoll
+
+;;;; Copyright (C) 2016 Andy Wingo <wingo@pobox.com>
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+(define-module (fibers epoll)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (rnrs bytevectors)
+  #:export (epoll-create
+            epoll-destroy
+            epoll?
+            epoll-add!
+            epoll-modify!
+            epoll-remove!
+            epoll
+
+            EPOLLIN EPOLLOUT EPOLLPRO EPOLLERR EPOLLHUP EPOLLET))
+
+(eval-when (eval load compile)
+  (load-extension "epoll" "init_fibers_epoll"))
+
+(when (defined? 'EPOLLRDHUP)
+  (export EPOLLRDHUP))
+(when (defined? 'EPOLLONESHOT)
+  (export EPOLLONESHOT))
+
+(define-record-type <epoll>
+  (make-epoll fd eventsv)
+  epoll?
+  (fd epoll-fd set-epoll-fd!)
+  (eventsv epoll-eventsv set-epoll-eventsv!))
+
+(define-syntax events-offset
+  (lambda (x)
+    (syntax-case x ()
+      ((_ n)
+       #`(* n #,%sizeof-struct-epoll-event)))))
+
+(define-syntax fd-offset
+  (lambda (x)
+    (syntax-case x ()
+      ((_ n)
+       #`(+ (* n #,%sizeof-struct-epoll-event)
+            #,%offsetof-struct-epoll-event-fd)))))
+
+(define epoll-guardian (make-guardian))
+(define (pump-epoll-guardian)
+  (let ((epoll (epoll-guardian)))
+    (when epoll
+      (epoll-destroy epoll)
+      (pump-epoll-guardian))))
+(add-hook! after-gc-hook pump-epoll-guardian)
+
+(define* (epoll-create #:key (close-on-exec? #t))
+  (let ((epoll (make-epoll (primitive-epoll-create close-on-exec?) #f)))
+    (epoll-guardian epoll)
+    epoll))
+
+(define (epoll-destroy epoll)
+  (when (epoll-fd epoll)
+    (close-fdes (epoll-fd epoll))
+    (set-epoll-fd! epoll #f)))
+
+(define (epoll-add! epoll fd events)
+  (primitive-epoll-ctl (epoll-fd epoll) EPOLL_CTL_ADD fd events))
+
+(define* (epoll-modify! epoll fd events)
+  (primitive-epoll-ctl (epoll-fd epoll) EPOLL_CTL_MOD fd events))
+
+(define (epoll-remove! epoll fd)
+  (primitive-epoll-ctl (epoll-fd epoll) EPOLL_CTL_DEL fd))
+
+(define (epoll-default-folder fd events seed)
+  (acons fd events seed))
+
+(define (ensure-epoll-eventsv epoll maxevents)
+  (let ((prev (epoll-eventsv epoll)))
+    (if (and prev
+             (or (not maxevents)
+                 (= (events-offset maxevents) (bytevector-length prev))))
+        prev
+        (let ((v (make-bytevector (events-offset (or maxevents 8)))))
+          (set-epoll-eventsv! epoll v)
+          v))))
+
+(define* (epoll epoll #:optional maxevents (timeout -1)
+                #:key (folder epoll-default-folder) (seed '()))
+  (let* ((eventsv (ensure-epoll-eventsv epoll maxevents))
+         (n (primitive-epoll-wait (epoll-fd epoll) eventsv timeout)))
+    (let lp ((seed seed) (i 0))
+      (if (< i n)
+          (lp (folder (bytevector-s32-native-ref eventsv (fd-offset i))
+                      (bytevector-u32-native-ref eventsv (events-offset i))
+                      seed)
+              (1+ i))
+          seed))))