Remove epoll dep on suspendable ports

* epoll.c (scm_primitive_epoll_wake): New function.
  (scm_primitive_epoll_wait): If the epoll was woken, drain the read
  pipe directly.
  (init_fibers_epoll): Adapt prototypes.
* fibers/epoll.scm (epoll-wake!): Use primitive-epoll-wake.
  (epoll): Let primitive-epoll-wait handle wakeup.

2 files changed, 50 insertions, 21 deletions

diff --git a/epoll.c b/epoll.c
index 5fd7f76..8e1f9c5 100644
--- a/epoll.c
+++ b/epoll.c
@@ -32,6 +32,22 @@
 /* {EPoll}
  */
 
+static SCM
+scm_primitive_epoll_wake (SCM wakefd)
+#define FUNC_NAME "primitive-epoll-wake"
+{
+  int c_fd;
+  char zero = 0;
+
+  c_fd = scm_to_int (wakefd);
+
+  if (write (c_fd, &zero, 1) <= 0 && errno != EWOULDBLOCK && errno != EAGAIN)
+    SCM_SYSERROR;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 /* 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.
@@ -101,14 +117,16 @@ scm_primitive_epoll_ctl (SCM epfd, SCM op, SCM fd, SCM events)
    which may be zero if no files triggered wakeups within TIMEOUT
    milliseconds.  */
 static SCM
-scm_primitive_epoll_wait (SCM epfd, SCM wakefd, SCM eventsv, SCM timeout)
+scm_primitive_epoll_wait (SCM epfd, SCM wakefd, SCM wokefd,
+                          SCM eventsv, SCM timeout)
 #define FUNC_NAME "primitive-epoll-wait"
 {
-  int c_epfd, c_wakefd, maxevents, rv, c_timeout;
+  int c_epfd, c_wakefd, c_wokefd, maxevents, rv, c_timeout;
   struct epoll_event *events;
 
   c_epfd = scm_to_int (epfd);
   c_wakefd = scm_to_int (wakefd);
+  c_wokefd = scm_to_int (wokefd);
 
   SCM_VALIDATE_BYTEVECTOR (SCM_ARG2, eventsv);
   if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (eventsv) % sizeof (*events)))
@@ -116,7 +134,7 @@ scm_primitive_epoll_wait (SCM epfd, SCM wakefd, SCM eventsv, SCM timeout)
 
   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);
+  c_timeout = scm_to_int (timeout);
 
   if (scm_c_prepare_to_wait_on_fd (c_wakefd))
     rv = 0;
@@ -135,6 +153,27 @@ scm_primitive_epoll_wait (SCM epfd, SCM wakefd, SCM eventsv, SCM timeout)
           else
             SCM_SYSERROR;
         }
+      else
+        {
+          /* Drain woke fd if appropriate.  Doing it from Scheme is a
+             bit gnarly as we don't know if suspendable ports are
+             enabled or not.  */
+          int i;
+          for (i = 0; i < rv; i++)
+            if (events[i].data.fd == c_wokefd)
+              {
+                char zeroes[32];
+                /* Remove wake fd from result set.  */
+                rv--;
+                memmove (events + i,
+                         events + i + 1,
+                         (rv - i) * sizeof (*events));
+                /* Drain fd and ignore errors. */
+                while (read (c_wokefd, zeroes, sizeof zeroes) == sizeof zeroes)
+                  ;
+                break;
+              }
+        }
     }
 
   return scm_from_int (rv);
@@ -148,11 +187,13 @@ scm_primitive_epoll_wait (SCM epfd, SCM wakefd, SCM eventsv, SCM timeout)
 void
 init_fibers_epoll (void)
 {
+  scm_c_define_gsubr ("primitive-epoll-wake", 1, 0, 0,
+                      scm_primitive_epoll_wake);
   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", 4, 1, 0,
+  scm_c_define_gsubr ("primitive-epoll-wait", 5, 0, 0,
                       scm_primitive_epoll_wait);
   scm_c_define ("%sizeof-struct-epoll-event",
                 scm_from_size_t (sizeof (struct epoll_event)));
diff --git a/fibers/epoll.scm b/fibers/epoll.scm
index 2853d21..83a0a63 100644
--- a/fibers/epoll.scm
+++ b/fibers/epoll.scm
@@ -22,7 +22,6 @@
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 suspendable-ports)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (rnrs bytevectors)
@@ -125,9 +124,7 @@ epoll wait (if appropriate)."
     ;; can avoid it if the epoll is guaranteed to see that the
     ;; runqueue is not empty before it goes to poll next time.
     ('waiting
-     (let/ec cancel
-       (parameterize ((current-write-waiter cancel))
-         (put-u8 (epoll-wake-write-pipe epoll) #x00))))
+     (primitive-epoll-wake (fileno (epoll-wake-write-pipe epoll))))
     ('not-waiting #t)
     ('dead (error "epoll instance is dead"))))
 
@@ -150,10 +147,9 @@ epoll wait (if appropriate)."
   (let* ((maxevents (epoll-maxevents epoll))
          (eventsv (ensure-epoll-eventsv epoll maxevents))
          (write-pipe-fd (fileno (epoll-wake-write-pipe epoll)))
-         (n (primitive-epoll-wait (epoll-fd epoll) write-pipe-fd
-                                  eventsv (get-timeout)))
-         (read-pipe (epoll-wake-read-pipe epoll))
-         (read-pipe-fd (fileno read-pipe)))
+         (read-pipe-fd (fileno (epoll-wake-read-pipe epoll)))
+         (n (primitive-epoll-wait (epoll-fd epoll) write-pipe-fd read-pipe-fd
+                                  eventsv (get-timeout))))
     ;; If we received `maxevents' events, it means that probably there
     ;; are more active fd's in the queue that we were unable to
     ;; receive.  Expand our event buffer in that case.
@@ -164,13 +160,5 @@ epoll wait (if appropriate)."
       (if (< i n)
           (let ((fd (bytevector-s32-native-ref eventsv (fd-offset i)))
                 (events (bytevector-u32-native-ref eventsv (events-offset i))))
-            (lp (if (eqv? fd read-pipe-fd)
-                    (begin
-                      (let/ec cancel
-                        ;; Slurp off any wake bytes from the fd.
-                        (parameterize ((current-read-waiter cancel))
-                          (let lp () (get-u8 read-pipe) (lp))))
-                      seed)
-                    (folder fd events seed))
-                (1+ i)))
+            (lp (folder fd events seed) (1+ i)))
           seed))))