diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | fibers/internal.scm | 54 | ||||
| -rw-r--r-- | fibers/stack.scm | 61 |
3 files changed, 93 insertions, 23 deletions
diff --git a/Makefile.am b/Makefile.am index 968b0b3..40892c5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -35,6 +35,7 @@ SOURCES = \ fibers/operations.scm \ fibers/posix-clocks.scm \ fibers/psq.scm \ + fibers/stack.scm \ fibers/repl.scm \ fibers/timers.scm \ web/server/fibers.scm 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 '())) |