Add support for preemption

* Makefile.am: Add new test.
* TODO.md: Remove stale TODO entries.
* fibers.scm (run-fibers): Add #:hz parameter.
* fibers.texi (Design): Mention that we support preemption.
  (Using Fibers): Update for preemption.
* fibers/internal.scm (<scheduler>): Add hz field.
  (make-scheduler): Add #:hz initarg.
  (maybe-preemptive): New helper.
  (run-scheduler): Use maybe-preemptive.
* tests/preemption.scm: New test.

1 files changed, 49 insertions, 18 deletions

diff --git a/fibers/internal.scm b/fibers/internal.scm
index bff342a..a80e478 100644
--- a/fibers/internal.scm
+++ b/fibers/internal.scm
@@ -78,7 +78,7 @@ name is known."
 
 (define-record-type <scheduler>
   (%make-scheduler name epfd active-fd-count prompt-tag runqueue
-                   sources timers kernel-thread)
+                   sources timers kernel-thread hz)
   scheduler?
   (name scheduler-name set-scheduler-name!)
   (epfd scheduler-epfd)
@@ -91,7 +91,8 @@ name is known."
   ;; PSQ of thunk -> expiry
   (timers scheduler-timers set-scheduler-timers!)
   ;; atomic parameter of thread
-  (kernel-thread scheduler-kernel-thread))
+  (kernel-thread scheduler-kernel-thread)
+  (hz scheduler-hz))
 
 (define-record-type <fiber>
   (make-fiber scheduler continuation)
@@ -114,7 +115,7 @@ name is known."
              (unless (eq? prev init)
                (error "owned by other thread" prev))))))))
 
-(define (make-scheduler)
+(define* (make-scheduler #:key (hz 0))
   "Make a new scheduler in which to run fibers."
   (let ((epfd (epoll-create))
         (active-fd-count 0)
@@ -126,7 +127,8 @@ name is known."
                           <))
         (kernel-thread (make-atomic-parameter #f)))
     (let ((sched (%make-scheduler #f epfd active-fd-count prompt-tag
-                                  runqueue sources timers kernel-thread)))
+                                  runqueue sources timers kernel-thread
+                                  hz)))
       (set-scheduler-name! sched (nameset-add! schedulers-nameset sched))
       sched)))
 
@@ -266,24 +268,53 @@ current."
         (set-fiber-continuation! fiber k)
         (after-suspend fiber)))))
 
+;; Using SIGPROF for preemption prevents using it for other purposes
+;; like profiling.  A better solution would be clock_nanosleep on the
+;; CLOCK_PROCESS_CPUTIME_ID clock from a separate thread.
+(define (maybe-preemptive sched thunk)
+  (let ((hz (scheduler-hz sched))
+        (tag (scheduler-prompt-tag sched))
+        (prev #f))
+    (define (sigprof-handler _)
+      (when (suspendable-continuation? tag)
+        (suspend-current-fiber
+         (lambda (fiber)
+           (resume-fiber fiber (lambda () (values)))))))
+
+    (define (start-preemption!)
+      (let ((period-usecs (inexact->exact (round (/ 1e6 hz)))))
+        (set! prev (car (sigaction SIGPROF sigprof-handler)))
+        (setitimer ITIMER_PROF 0 period-usecs 0 period-usecs)))
+
+    (define (stop-preemption!)
+      (setitimer ITIMER_PROF 0 0 0 0)
+      (sigaction SIGPROF prev))
+
+    (if (zero? hz)
+        (thunk)
+        (dynamic-wind start-preemption! thunk stop-preemption!))))
+
 (define* (run-scheduler sched)
   "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)))))
+  (maybe-preemptive
+   sched
+   (lambda ()
+     (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)))))))
 
 (define (destroy-scheduler sched)
   "Release any resources associated with @var{sched}."