From 8edf9e4397f7aa0d27b4b3347380c133bfe73c26 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 17 Feb 2017 14:11:25 +0100
Subject: Lower preemption overhead

* fibers/interrupts.scm (with-interrupts/sigprof):
  (with-interrupts/thread-cputime, with-interrupts): Separate predicate
  from interrupt routine, so that predicate can run off-thread.
* fibers.scm (%run-fibers): Adapt.
---
 fibers.scm            |  9 +++++----
 fibers/interrupts.scm | 16 +++++++++-------
 2 files changed, 14 insertions(+), 11 deletions(-)

diff --git a/fibers.scm b/fibers.scm
index a0d6bab..ee02f67 100644
--- a/fibers.scm
+++ b/fibers.scm
@@ -61,10 +61,11 @@
        hz
        (let ((last-runcount 0))
          (lambda ()
-           (let ((runcount (scheduler-runcount scheduler)))
-             (when (eqv? runcount last-runcount)
-               (yield-current-fiber))
-             (set! last-runcount runcount))))
+           (let* ((runcount (scheduler-runcount scheduler))
+                  (res (eqv? runcount last-runcount)))
+             (set! last-runcount runcount)
+             res)))
+       yield-current-fiber
        (lambda ()
          (run-scheduler scheduler finished?)))))))
 
diff --git a/fibers/interrupts.scm b/fibers/interrupts.scm
index 9800877..5dceb03 100644
--- a/fibers/interrupts.scm
+++ b/fibers/interrupts.scm
@@ -25,9 +25,10 @@
 ;; Cause periodic interrupts via `setitimer' and SIGPROF.  This
 ;; implementation has the disadvantage that it prevents `setitimer'
 ;; from being used for other purposes like profiling.
-(define (with-interrupts/sigprof hz interrupt thunk)
+(define (with-interrupts/sigprof hz pred interrupt thunk)
   (let ((prev #f))
-    (define (sigprof-handler _) (interrupt))
+    (define (sigprof-handler _)
+      (when (pred) (interrupt)))
 
     (define (start-preemption!)
       (let ((period-usecs (inexact->exact (round (/ 1e6 hz)))))
@@ -42,7 +43,7 @@
 
 ;; Cause periodic interrupts via a separate thread sleeping on a clock
 ;; driven by the current thread's CPU time.
-(define (with-interrupts/thread-cputime hz interrupt thunk)
+(define (with-interrupts/thread-cputime hz pred interrupt thunk)
   (let ((interrupt-thread #f)
         (target-thread (current-thread))
         (clockid (pthread-getcpuclockid (pthread-self))))
@@ -59,7 +60,8 @@
              (false-if-exception
               (let lp ()
                 (clock-nanosleep clockid period-nsecs)
-                (system-async-mark interrupt target-thread)
+                (when (pred)
+                  (system-async-mark interrupt target-thread))
                 (lp))))))))
 
     (define (stop-preemption!)
@@ -67,13 +69,13 @@
 
     (dynamic-wind start-preemption! thunk stop-preemption!)))
 
-(define (with-interrupts hz interrupt thunk)
+(define (with-interrupts hz pred interrupt thunk)
   "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."
   (cond
    ((zero? hz) (thunk))
    ((provided? 'threads)
-    (with-interrupts/thread-cputime hz interrupt thunk))
+    (with-interrupts/thread-cputime hz pred interrupt thunk))
    (else
-    (with-interrupts/sigprof hz interrupt thunk))))
+    (with-interrupts/sigprof hz pred interrupt thunk))))
-- 
cgit v1.2.3