[Guile-commits] 03/23: add (ice-9 epoll)

[Andy Wingo]

wingo pushed a commit to branch wip-ethreads
in repository guile.

commit f2446e79ab0b40720aca507d866d893a8211fd6c
Author: Andy Wingo <address@hidden>
Date:   Thu Mar 15 12:16:22 2012 +0100

    add (ice-9 epoll)
    
    * configure.ac: Add checks for sys/epoll.h, epoll_create, and
      epoll_create1.
    
    * libguile/poll.c (scm_primitive_epoll_create, scm_primitive_epoll_ctl)
      (scm_primitive_epoll_wait): New primitives for (ice-9 epoll).
      Registered via a scm_init_epoll extension.
    
    * module/Makefile.am: Add ice-9/epoll.scm.
    
    * module/ice-9/epoll.scm: New file.
---
 configure.ac           |    4 +-
 libguile/poll.c        |  149 ++++++++++++++++++++++++++++++++++++++++++++++++
 module/Makefile.am     |    1 +
 module/ice-9/epoll.scm |  112 ++++++++++++++++++++++++++++++++++++
 4 files changed, 265 insertions(+), 1 deletions(-)

diff --git a/configure.ac b/configure.ac
index 0eb2368..5ff96e0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -664,7 +664,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h 
memory.h process.h strin
 sys/dir.h sys/ioctl.h sys/select.h \
 sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
 sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h machine/fpu.h sched.h sys/sendfile.h])
+direct.h machine/fpu.h sched.h sys/epoll.h sys/sendfile.h])
 
 # "complex double" is new in C99, and "complex" is only a keyword if
 # <complex.h> is included
@@ -739,6 +739,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #       for gcc to provide the "complex double" type but the system to not
 #       have functions like cexp and clog
 #   clog10 - not in mingw (though others like clog and csqrt are)
+#   epoll_create, epoll_create1: glibc/Linux API
 #   fesetround - available in C99, but not older systems
 #   ftruncate - posix, but probably not older systems (current mingw
 #               has it as an inline for chsize)
@@ -757,6 +758,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #   sendfile - non-POSIX, found in glibc
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid                
\
+  epoll_create epoll_create1                                           \
   fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid       \
   gettimeofday gmtime_r ioctl lstat mkdir mknod nice                   \
   readdir_r readdir64_r readlink rename rmdir setegid seteuid          \
diff --git a/libguile/poll.c b/libguile/poll.c
index 9ea846b..234ff82 100644
--- a/libguile/poll.c
+++ b/libguile/poll.c
@@ -27,6 +27,11 @@
 
 #include <poll.h>
 
+#ifdef HAVE_SYS_EPOLL_H
+#include <sys/epoll.h>
+#define HAVE_EPOLL
+#endif
+
 #include "libguile/_scm.h"
 #include "libguile/bytevectors.h"
 #include "libguile/numbers.h"
@@ -174,6 +179,110 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM 
timeout)
 
 
 
+/* {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 `(ice-9 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.  */
+#ifdef HAVE_EPOLL
+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);
+
+  SCM_SYSCALL (rv = epoll_wait (c_epfd, events, maxevents, c_timeout));
+
+  if (rv == -1)
+    SCM_SYSERROR;
+
+  return scm_from_int (rv);
+}
+#undef FUNC_NAME
+
+#endif /* HAVE_EPOLL */
+
+
+
+
+/* Low-level helpers for (ice-9 poll).  */
 static void
 scm_init_poll (void)
 {
@@ -204,6 +313,41 @@ scm_init_poll (void)
 
 }
 
+/* Low-level helpers for (ice-9 epoll).  */
+static void
+scm_init_epoll (void)
+{
+#ifdef HAVE_EPOLL
+  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));
+#else
+  scm_misc_error ("%init-epoll", "`epoll' unavailable on this platform", 
SCM_EOL);
+#endif
+}
+
 void
 scm_register_poll (void)
 {
@@ -211,6 +355,11 @@ scm_register_poll (void)
                             "scm_init_poll",
                            (scm_t_extension_init_func) scm_init_poll,
                            NULL);
+
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_epoll",
+                           (scm_t_extension_init_func) scm_init_epoll,
+                           NULL);
 }
 
 /*
diff --git a/module/Makefile.am b/module/Makefile.am
index f44a7a6..76734e6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -56,6 +56,7 @@ SOURCES =                                     \
   ice-9/debug.scm                              \
   ice-9/deprecated.scm                         \
   ice-9/documentation.scm                      \
+  ice-9/epoll.scm                              \
   ice-9/eports.scm                             \
   ice-9/eval-string.scm                                \
   ice-9/eval.scm                               \
diff --git a/module/ice-9/epoll.scm b/module/ice-9/epoll.scm
new file mode 100644
index 0000000..e10c5ff
--- /dev/null
+++ b/module/ice-9/epoll.scm
@@ -0,0 +1,112 @@
+;; epoll
+
+;;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;;; 
+;;;; 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 (ice-9 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 (string-append "libguile-" (effective-version))
+                  "scm_init_epoll"))
+
+(if (defined? 'EPOLLRDHUP)
+    (export EPOLLRDHUP))
+(if (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))))