;;;; runq.scm --- the runq data structure
;;;;
;;;; Copyright (C) 1996, 2001, 2006, 2010 Free Software Foundation, Inc.
;;;;
;;;; 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
;;;;
;;; Commentary:
;;; One way to schedule parallel computations in a serial environment is
;;; to explicitly divide each task up into small, finite execution time,
;;; strips. Then you interleave the execution of strips from various
;;; tasks to achieve a kind of parallelism. Runqs are a handy data
;;; structure for this style of programming.
;;;
;;; We use thunks (nullary procedures) and lists of thunks to represent
;;; strips. By convention, the return value of a strip-thunk must either
;;; be another strip or the value #f.
;;;
;;; A runq is a procedure that manages a queue of strips. Called with no
;;; arguments, it processes one strip from the queue. Called with
;;; arguments, the arguments form a control message for the queue. The
;;; first argument is a symbol which is the message selector.
;;;
;;; A strip is processed this way: If the strip is a thunk, the thunk is
;;; called -- if it returns a strip, that strip is added back to the
;;; queue. To process a strip which is a list of thunks, the CAR of that
;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
;;; original strip if that CDR is not nil. The runq puts whichever of
;;; these strips exist back on the queue. (The exact order in which
;;; strips are put back on the queue determines the scheduling behavior of
;;; a particular queue -- it's a parameter.)
;;; Code:
(define-module (ice-9 runq)
:use-module (ice-9 q)
:export (runq-control make-void-runq make-fair-runq
make-exclusive-runq make-subordinate-runq-to strip-sequence
fair-strip-subtask))
;;;;
;;; (runq-control q msg . args)
;;;
;;; processes in the default way the control messages that
;;; can be sent to a runq. Q should be an ordinary
;;; Q (see utils/q.scm).
;;;
;;; The standard runq messages are:
;;;
;;; 'add! strip0 strip1... ;; to enqueue one or more strips
;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
;;; 'push! strip0 ... ;; add strips to the front of the queue
;;; 'empty? ;; true if it is
;;; 'length ;; how many strips in the queue?
;;; 'kill! ;; empty the queue
;;; else ;; throw 'not-understood
;;;
(define (runq-control q msg . args)
(case msg
((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
((enqueue!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
((empty?) (q-empty? q))
((length) (q-length q))
((kill!) (set! q (make-q)))
(else (throw 'not-understood msg args))))
(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
;;;;
;;; make-void-runq
;;;
;;; Make a runq that discards all messages except "length", for which
;;; it returns 0.
;;;
(define (make-void-runq)
(lambda opts
(and opts
(apply-to-args opts
(lambda (msg . args)
(case msg
((length) 0)
(else #f)))))))
;;;;
;;; (make-fair-runq)
;;;
;;; Returns a runq procedure.
;;; Called with no arguments, the procedure processes one strip from the queue.
;;; Called with arguments, it uses runq-control.
;;;
;;; In a fair runq, if a strip returns a new strip X, X is added
;;; to the end of the queue, meaning it will be the last to execute
;;; of all the remaining procedures.
;;;
(define (make-fair-runq)
(letrec ((q (make-q))
(self
(lambda ctl
(if ctl
(apply runq-control q ctl)
(and (not (q-empty? q))
(let ((next-strip (deq! q)))
(cond
((procedure? next-strip) (let ((k (run-strip next-strip)))
(and k (enq! q k))))
((pair? next-strip) (let ((k (run-strip (car next-strip))))
(and k (enq! q k)))
(if (not (null? (cdr next-strip)))
(enq! q (cdr next-strip)))))
self))))))
self))
;;;;
;;; (make-exclusive-runq)
;;;
;;; Returns a runq procedure.
;;; Called with no arguments, the procedure processes one strip from the queue.
;;; Called with arguments, it uses runq-control.
;;;
;;; In an exclusive runq, if a strip W returns a new strip X, X is added
;;; to the front of the queue, meaning it will be the next to execute
;;; of all the remaining procedures.
;;;
;;; An exception to this occurs if W was the CAR of a list of strips.
;;; In that case, after the return value of W is pushed onto the front
;;; of the queue, the CDR of the list of strips is pushed in front
;;; of that (if the CDR is not nil). This way, the rest of the thunks
;;; in the list that contained W have priority over the return value of W.
;;;
(define (make-exclusive-runq)
(letrec ((q (make-q))
(self
(lambda ctl
(if ctl
(apply runq-control q ctl)
(and (not (q-empty? q))
(let ((next-strip (deq! q)))
(cond
((procedure? next-strip) (let ((k (run-strip next-strip)))
(and k (q-push! q k))))
((pair? next-strip) (let ((k (run-strip (car next-strip))))
(and k (q-push! q k)))
(if (not (null? (cdr next-strip)))
(q-push! q (cdr next-strip)))))
self))))))
self))
;;;;
;;; (make-subordinate-runq-to superior basic-inferior)
;;;
;;; Returns a runq proxy for the runq basic-inferior.
;;;
;;; The proxy watches for operations on the basic-inferior that cause
;;; a transition from a queue length of 0 to a non-zero length and
;;; vice versa. While the basic-inferior queue is not empty,
;;; the proxy installs a task on the superior runq. Each strip
;;; of that task processes N strips from the basic-inferior where
;;; N is the length of the basic-inferior queue when the proxy
;;; strip is entered. [Countless scheduling variations are possible.]
;;;
(define (make-subordinate-runq-to superior-runq basic-runq)
(let ((runq-task (cons #f #f)))
(set-car! runq-task
(lambda ()
(if (basic-runq 'empty?)
(set-cdr! runq-task #f)
(do ((n (basic-runq 'length) (1- n)))
((<= n 0) #f)
(basic-runq)))))
(letrec ((self
(lambda ctl
(if (not ctl)
(let ((answer (basic-runq)))
(self 'empty?)
answer)
(begin
(case (car ctl)
((suspend) (set-cdr! runq-task #f))
(else (let ((answer (apply basic-runq ctl)))
(if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
(begin
(set-cdr! runq-task runq-task)
(superior-runq 'add! runq-task)))
answer))))))))
self)))
;;;;
;;; (define fork-strips (lambda args args))
;;; Return a strip that starts several strips in
;;; parallel. If this strip is enqueued on a fair
;;; runq, strips of the parallel subtasks will run
;;; round-robin style.
;;;
;;;;
;;; (strip-sequence . strips)
;;;
;;; Returns a new strip which is the concatenation of the argument strips.
;;;
(define (strip-sequence . strips)
(lambda ()
(let loop ((st (let ((a strips)) (set! strips #f) a)))
(and (not (null? st))
(let ((then ((car st))))
(if then
(lambda () (loop (cons then (cdr st))))
(lambda () (loop (cdr st)))))))))
;;;;
;;; (fair-strip-subtask . initial-strips)
;;;
;;; Returns a new strip which is the synchronos, fair,
;;; parallel execution of the argument strips.
;;;
;;;
;;;
(define (fair-strip-subtask . initial-strips)
(let ((st (make-fair-runq)))
(apply st 'add! initial-strips)
st))
;;; runq.scm ends here