From 89b9e58bf3789bc18ee2c680add3962cc75423c0 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 17 Feb 2017 14:00:31 +0100
Subject: Prevent spurious preemption

* fibers/internal.scm (<scheduler>, make-scheduler):
  (scheduler-runcount, run-scheduler): Maintain a count of run fibers.
* fibers.scm (%run-fibers): Only cause the current fiber to suspend if
  the runcount isn't advancing.
---
 fibers.scm          |  8 +++++++-
 fibers/internal.scm | 16 ++++++++++++++--
 2 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/fibers.scm b/fibers.scm
index 8ae1d92..a0d6bab 100644
--- a/fibers.scm
+++ b/fibers.scm
@@ -58,7 +58,13 @@
     (parameterize ((current-read-waiter wait-for-readable)
                    (current-write-waiter wait-for-writable))
       (with-interrupts
-       hz yield-current-fiber
+       hz
+       (let ((last-runcount 0))
+         (lambda ()
+           (let ((runcount (scheduler-runcount scheduler)))
+             (when (eqv? runcount last-runcount)
+               (yield-current-fiber))
+             (set! last-runcount runcount))))
        (lambda ()
          (run-scheduler scheduler finished?)))))))
 
diff --git a/fibers/internal.scm b/fibers/internal.scm
index 1345ae0..31b17b8 100644
--- a/fibers/internal.scm
+++ b/fibers/internal.scm
@@ -32,6 +32,7 @@
             make-scheduler
             with-scheduler
             scheduler-name
+            scheduler-runcount
             (scheduler-kernel-thread/public . scheduler-kernel-thread)
             scheduler-remote-peers
             choose-parallel-scheduler
@@ -79,13 +80,15 @@ name is known."
   (nameset-ref fibers-nameset name))
 
 (define-record-type <scheduler>
-  (%make-scheduler name epfd prompt-tag
+  (%make-scheduler name epfd runcount-box prompt-tag
                    next-runqueue current-runqueue
                    sources timers kernel-thread
                    remote-peers choose-parallel-scheduler)
   scheduler?
   (name scheduler-name set-scheduler-name!)
   (epfd scheduler-epfd)
+  ;; atomic variable of uint32
+  (runcount-box scheduler-runcount-box)
   (prompt-tag scheduler-prompt-tag)
   ;; atomic stack of fiber to run next turn (reverse order)
   (next-runqueue scheduler-next-runqueue)
@@ -143,6 +146,7 @@ name is known."
                          (prompt-tag (make-prompt-tag "fibers")))
   "Make a new scheduler in which to run fibers."
   (let ((epfd (epoll-create))
+        (runcount-box (make-atomic-box 0))
         (next-runqueue (make-empty-stack))
         (current-runqueue (make-empty-stack))
         (sources (make-hash-table))
@@ -150,7 +154,7 @@ name is known."
                             (((t1 . c1) (t2 . c2)) (< t1 t2)))
                           <))
         (kernel-thread (make-atomic-parameter #f)))
-    (let ((sched (%make-scheduler #f epfd prompt-tag
+    (let ((sched (%make-scheduler #f epfd runcount-box prompt-tag
                                   next-runqueue current-runqueue
                                   sources timers kernel-thread
                                   #f #f)))
@@ -183,6 +187,11 @@ thread."
                   (lambda ()
                     ((scheduler-kernel-thread sched) #f)))))
 
+(define (scheduler-runcount sched)
+  "Return the number of fibers that have been scheduled on
+@var{sched} since it was started, modulo 2@sup{32}."
+  (atomic-box-ref (scheduler-runcount-box sched)))
+
 (define (scheduler-kernel-thread/public sched)
   "Return the kernel thread on which @var{sched} is running, or
 @code{#f} if @var{sched} is not running."
@@ -301,10 +310,13 @@ stolen."
 file descriptors being waited on, and no more timers pending to run.
 Return zero values."
   (let ((tag (scheduler-prompt-tag sched))
+        (runcount-box (scheduler-runcount-box sched))
         (next (scheduler-next-runqueue sched))
         (cur (scheduler-current-runqueue sched))
         (steal-fiber! (fiber-stealer sched)))
     (define (run-fiber fiber)
+      (atomic-box-set! runcount-box
+                       (logand (1+ (atomic-box-ref runcount-box)) #xffffFFFF))
       (call-with-prompt tag
         (lambda ()
           (let ((thunk (fiber-continuation fiber)))
-- 
cgit v1.2.3