Rework runqueue as pair of stacks

* fibers/stack.scm: New file.
* Makefile.am: Add new file.
* fibers/internal.scm: Rework runqueue to have separate current and next
  stacks.  We want to expose the current runqueue so that remote
  schedulers can steal work, but we also need to know when we flip the
  next runqueue to the current runqueue so that we can pull in
  additional wakeups from epoll and timers.

2 files changed, 92 insertions, 23 deletions

diff --git a/fibers/internal.scm b/fibers/internal.scm
index 7369c27..4398937 100644
--- a/fibers/internal.scm
+++ b/fibers/internal.scm
@@ -19,7 +19,7 @@
 
 (define-module (fibers internal)
   #:use-module (srfi srfi-9)
-  #:use-module (fibers deque)
+  #:use-module (fibers stack)
   #:use-module (fibers epoll)
   #:use-module (fibers psq)
   #:use-module (fibers nameset)
@@ -78,15 +78,18 @@ name is known."
   (nameset-ref fibers-nameset name))
 
 (define-record-type <scheduler>
-  (%make-scheduler name epfd active-fd-count prompt-tag runqueue
+  (%make-scheduler name epfd active-fd-count prompt-tag
+                   next-runqueue current-runqueue
                    sources timers kernel-thread)
   scheduler?
   (name scheduler-name set-scheduler-name!)
   (epfd scheduler-epfd)
   (active-fd-count scheduler-active-fd-count set-scheduler-active-fd-count!)
   (prompt-tag scheduler-prompt-tag)
-  ;; atomic box of deque of fiber
-  (runqueue scheduler-runqueue)
+  ;; atomic stack of fiber to run next turn (reverse order)
+  (next-runqueue scheduler-next-runqueue)
+  ;; atomic stack of fiber to run this turn
+  (current-runqueue scheduler-current-runqueue)
   ;; fd -> ((total-events . min-expiry) #(events expiry fiber) ...)
   (sources scheduler-sources)
   ;; PSQ of thunk -> expiry
@@ -120,14 +123,16 @@ name is known."
   (let ((epfd (epoll-create))
         (active-fd-count 0)
         (prompt-tag (make-prompt-tag "fibers"))
-        (runqueue (make-atomic-box (make-empty-deque)))
+        (next-runqueue (make-empty-stack))
+        (current-runqueue (make-empty-stack))
         (sources (make-hash-table))
         (timers (make-psq (match-lambda*
                             (((t1 . c1) (t2 . c2)) (< t1 t2)))
                           <))
         (kernel-thread (make-atomic-parameter #f)))
     (let ((sched (%make-scheduler #f epfd active-fd-count prompt-tag
-                                  runqueue sources timers kernel-thread)))
+                                  next-runqueue current-runqueue
+                                  sources timers kernel-thread)))
       (set-scheduler-name! sched (nameset-add! schedulers-nameset sched))
       sched)))
 
@@ -173,7 +178,7 @@ current."
   ;; for a fiber scheduled on a remote thread.
   (set-fiber-continuation! fiber thunk)
   (let ((sched (fiber-scheduler fiber)))
-    (enqueue! (scheduler-runqueue sched) fiber)
+    (stack-push! (scheduler-next-runqueue sched) fiber)
     (unless (eq? sched (current-scheduler))
       (epoll-wake! (scheduler-epfd sched)))
     (values)))
@@ -211,7 +216,7 @@ current."
 
 (define (scheduler-poll-timeout sched)
   (cond
-   ((not (empty-deque? (atomic-box-ref (scheduler-runqueue sched))))
+   ((not (stack-empty? (scheduler-next-runqueue sched)))
     ;; Don't sleep if there are fibers in the runqueue already.
     0)
    ((psq-empty? (scheduler-timers sched))
@@ -275,25 +280,28 @@ current."
   "Run @var{sched} until there are no more fibers ready to run, no
 file descriptors being waited on, and no more timers pending to run.
 Return zero values."
-  (let lp ()
-    (schedule-runnables-for-next-turn sched)
-    (match (dequeue-all! (scheduler-runqueue sched))
-      (()
-       ;; Could be the scheduler is stopping, or it could be that we
-       ;; got a spurious wakeup.  In any case, this is the place to
-       ;; check to see whether the scheduler is really done.
-       (cond
-        ((not (zero? (scheduler-active-fd-count sched))) (lp))
-        ((not (psq-empty? (scheduler-timers sched))) (lp))
-        (else (values))))
-      (runnables
-       (for-each run-fiber runnables)
-       (lp)))))
+  (let ((next (scheduler-next-runqueue sched))
+        (cur (scheduler-current-runqueue sched)))
+    (let lp ()
+      (schedule-runnables-for-next-turn sched)
+      (stack-push-list! cur (reverse (stack-pop-all! next)))
+      (match (stack-pop-all! cur)
+        (()
+         ;; Could be the scheduler is stopping, or it could be that we
+         ;; got a spurious wakeup.  In any case, this is the place to
+         ;; check to see whether the scheduler is really done.
+         (cond
+          ((not (zero? (scheduler-active-fd-count sched))) (lp))
+          ((not (psq-empty? (scheduler-timers sched))) (lp))
+          (else (values))))
+        (runnables
+         (for-each run-fiber runnables)
+         (lp))))))
 
 (define (steal-work! sched)
   "Steal some work from @var{sched}.  Return a list of runnable fibers
 in FIFO order, or the empty list if no work could be stolen."
-  (match (dequeue! (scheduler-runqueue sched) #f)
+  (match (stack-pop! (scheduler-current-runqueue sched) #f)
     (#f '())
     (fiber (list fiber))))
 
diff --git a/fibers/stack.scm b/fibers/stack.scm
new file mode 100644
index 0000000..cd2c1c6
--- /dev/null
+++ b/fibers/stack.scm
@@ -0,0 +1,61 @@
+;; Atomic stack
+
+;;;; 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 stack)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 match)
+  #:export (make-empty-stack
+            stack-empty?
+            stack-push!
+            stack-push-list!
+            stack-pop!
+            stack-pop-all!))
+
+(define (make-empty-stack)
+  (make-atomic-box '()))
+
+(define (stack-empty? stack)
+  (match (atomic-box-ref stack)
+    (() #t)
+    (_ #f)))
+
+(define-inlinable (update! box f)
+  (let spin ((x (atomic-box-ref box)))
+    (call-with-values (lambda () (f x))
+      (lambda (x* ret)
+        (if (eq? x x*)
+            ret
+            (let ((x** (atomic-box-compare-and-swap! box x x*)))
+              (if (eq? x x**)
+                  ret
+                  (spin x**))))))))
+
+(define (stack-push! sbox elt)
+  (update! sbox (lambda (stack) (values (cons elt stack) #f))))
+
+(define (stack-push-list! sbox elts)
+  (update! sbox (lambda (stack) (values (append elts stack) #f))))
+
+(define* (stack-pop! sbox #:optional default)
+  (update! sbox (lambda (stack)
+                  (match stack
+                    ((elt . stack) (values stack elt))
+                    (_ (values stack default))))))
+
+(define (stack-pop-all! sbox)
+  (atomic-box-swap! sbox '()))