ice-9/runq.scm

   1 ;;;; runq.scm --- the runq data structure
   2 ;;;;
   3 ;;;;    Copyright (C) 1996, 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43 ;;;;
  44
  45 ;;; Commentary:
  46
  47 ;;; One way to schedule parallel computations in a serial environment is
  48 ;;; to explicitly divide each task up into small, finite execution time,
  49 ;;; strips.  Then you interleave the execution of strips from various
  50 ;;; tasks to achieve a kind of parallelism.  Runqs are a handy data
  51 ;;; structure for this style of programming.
  52 ;;;
  53 ;;; We use thunks (nullary procedures) and lists of thunks to represent
  54 ;;; strips.  By convention, the return value of a strip-thunk must either
  55 ;;; be another strip or the value #f.
  56 ;;;
  57 ;;; A runq is a procedure that manages a queue of strips.  Called with no
  58 ;;; arguments, it processes one strip from the queue.  Called with
  59 ;;; arguments, the arguments form a control message for the queue.  The
  60 ;;; first argument is a symbol which is the message selector.
  61 ;;;
  62 ;;; A strip is processed this way: If the strip is a thunk, the thunk is
  63 ;;; called -- if it returns a strip, that strip is added back to the
  64 ;;; queue.  To process a strip which is a list of thunks, the CAR of that
  65 ;;; list is called.  After a call to that CAR, there are 0, 1, or 2 strips
  66 ;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
  67 ;;; original strip if that CDR is not nil.  The runq puts whichever of
  68 ;;; these strips exist back on the queue.  (The exact order in which
  69 ;;; strips are put back on the queue determines the scheduling behavior of
  70 ;;; a particular queue -- it's a parameter.)
  71
  72 ;;; Code:
  73
  74 (define-module (ice-9 runq)
  75   :use-module (ice-9 q)
  76   :export (runq-control make-void-runq make-fair-runq
  77            make-exclusive-runq make-subordinate-runq-to strip-sequence
  78            fair-strip-subtask))
  79
  80 ;;;;
  81 ;;;     (runq-control q msg . args)
  82 ;;;
  83 ;;;             processes in the default way the control messages that
  84 ;;;             can be sent to a runq.  Q should be an ordinary
  85 ;;;             Q (see utils/q.scm).
  86 ;;;
  87 ;;;             The standard runq messages are:
  88 ;;;
  89 ;;;             'add! strip0 strip1...          ;; to enqueue one or more strips
  90 ;;;             'enqueue! strip0 strip1...      ;; to enqueue one or more strips
  91 ;;;             'push! strip0 ...               ;; add strips to the front of the queue
  92 ;;;             'empty?                         ;; true if it is
  93 ;;;             'length                         ;; how many strips in the queue?
  94 ;;;             'kill!                          ;; empty the queue
  95 ;;;             else                            ;; throw 'not-understood
  96 ;;;
  97 (define (runq-control q msg . args)
  98   (case msg
  99     ((add!)                     (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
 100     ((enqueue!)                 (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
 101     ((push!)                    (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
 102     ((empty?)                   (q-empty? q))
 103     ((length)                   (q-length q))
 104     ((kill!)                    (set! q (make-q)))
 105     (else                       (throw 'not-understood msg args))))
 106
 107 (define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
 108
 109 ;;;;
 110 ;;; make-void-runq
 111 ;;;
 112 ;;; Make a runq that discards all messages except "length", for which
 113 ;;; it returns 0.
 114 ;;;
 115 (define (make-void-runq)
 116   (lambda opts
 117     (and opts
 118         (apply-to-args opts
 119           (lambda (msg . args)
 120             (case msg
 121               ((length)         0)
 122               (else             #f)))))))
 123
 124 ;;;;
 125 ;;;     (make-fair-runq)
 126 ;;;
 127 ;;;             Returns a runq procedure.
 128 ;;;             Called with no arguments, the procedure processes one strip from the queue.
 129 ;;;             Called with arguments, it uses runq-control.
 130 ;;;
 131 ;;;             In a fair runq, if a strip returns a new strip X, X is added
 132 ;;;             to the end of the queue, meaning it will be the last to execute
 133 ;;;             of all the remaining procedures.
 134 ;;;
 135 (define (make-fair-runq)
 136   (letrec ((q (make-q))
 137            (self
 138             (lambda ctl
 139               (if ctl
 140                   (apply runq-control q ctl)
 141                   (and (not (q-empty? q))
 142                        (let ((next-strip (deq! q)))
 143                          (cond
 144                           ((procedure? next-strip)      (let ((k (run-strip next-strip)))
 145                                                           (and k (enq! q k))))
 146                           ((pair? next-strip) (let ((k (run-strip (car next-strip))))
 147                                                 (and k (enq! q k)))
 148                                               (if (not (null? (cdr next-strip)))
 149                                                   (enq! q (cdr next-strip)))))
 150                          self))))))
 151     self))
 152
 153
 154 ;;;;
 155 ;;;     (make-exclusive-runq)
 156 ;;;
 157 ;;;             Returns a runq procedure.
 158 ;;;             Called with no arguments, the procedure processes one strip from the queue.
 159 ;;;             Called with arguments, it uses runq-control.
 160 ;;;
 161 ;;;             In an exclusive runq, if a strip W returns a new strip X, X is added
 162 ;;;             to the front of the queue, meaning it will be the next to execute
 163 ;;;             of all the remaining procedures.
 164 ;;;
 165 ;;;             An exception to this occurs if W was the CAR of a list of strips.
 166 ;;;             In that case, after the return value of W is pushed onto the front
 167 ;;;             of the queue, the CDR of the list of strips is pushed in front
 168 ;;;             of that (if the CDR is not nil).   This way, the rest of the thunks
 169 ;;;             in the list that contained W have priority over the return value of W.
 170 ;;;
 171 (define (make-exclusive-runq)
 172   (letrec ((q (make-q))
 173            (self
 174             (lambda ctl
 175               (if ctl
 176                   (apply runq-control q ctl)
 177                   (and (not (q-empty? q))
 178                        (let ((next-strip (deq! q)))
 179                          (cond
 180                           ((procedure? next-strip)      (let ((k (run-strip next-strip)))
 181                                                           (and k (q-push! q k))))
 182                           ((pair? next-strip) (let ((k (run-strip (car next-strip))))
 183                                                 (and k (q-push! q k)))
 184                                               (if (not (null? (cdr next-strip)))
 185                                                   (q-push! q (cdr next-strip)))))
 186                          self))))))
 187     self))
 188
 189
 190 ;;;;
 191 ;;;     (make-subordinate-runq-to superior basic-inferior)
 192 ;;;
 193 ;;;             Returns a runq proxy for the runq basic-inferior.
 194 ;;;
 195 ;;;             The proxy watches for operations on the basic-inferior that cause
 196 ;;;             a transition from a queue length of 0 to a non-zero length and
 197 ;;;             vice versa.   While the basic-inferior queue is not empty,
 198 ;;;             the proxy installs a task on the superior runq.  Each strip
 199 ;;;             of that task processes N strips from the basic-inferior where
 200 ;;;             N is the length of the basic-inferior queue when the proxy
 201 ;;;             strip is entered.  [Countless scheduling variations are possible.]
 202 ;;;
 203 (define (make-subordinate-runq-to superior-runq basic-runq)
 204   (let ((runq-task (cons #f #f)))
 205     (set-car! runq-task
 206               (lambda ()
 207                 (if (basic-runq 'empty?)
 208                     (set-cdr! runq-task #f)
 209                     (do ((n (basic-runq 'length) (1- n)))
 210                         ((<= n 0)                #f)
 211                       (basic-runq)))))
 212     (letrec ((self
 213               (lambda ctl
 214                 (if (not ctl)
 215                     (let ((answer (basic-runq)))
 216                       (self 'empty?)
 217                       answer)
 218                     (begin
 219                       (case (car ctl)
 220                         ((suspend)              (set-cdr! runq-task #f))
 221                         (else                   (let ((answer (apply basic-runq ctl)))
 222                                                   (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
 223                                                       (begin
 224                                                         (set-cdr! runq-task runq-task)
 225                                                         (superior-runq 'add! runq-task)))
 226                                                   answer))))))))
 227       self)))
 228
 229 ;;;;
 230 ;;;     (define fork-strips (lambda args args))
 231 ;;;             Return a strip that starts several strips in
 232 ;;;             parallel.   If this strip is enqueued on a fair
 233 ;;;             runq, strips of the parallel subtasks will run
 234 ;;;             round-robin style.
 235 ;;;
 236 (define fork-strips (lambda args args))
 237
 238
 239 ;;;;
 240 ;;;     (strip-sequence . strips)
 241 ;;;
 242 ;;;             Returns a new strip which is the concatenation of the argument strips.
 243 ;;;
 244 (define ((strip-sequence . strips))
 245   (let loop ((st (let ((a strips)) (set! strips #f) a)))
 246     (and (not (null? st))
 247          (let ((then ((car st))))
 248            (if then
 249                (lambda () (loop (cons then (cdr st))))
 250                (lambda () (loop (cdr st))))))))
 251
 252
 253 ;;;;
 254 ;;;     (fair-strip-subtask . initial-strips)
 255 ;;;
 256 ;;;             Returns a new strip which is the synchronos, fair,
 257 ;;;             parallel execution of the argument strips.
 258 ;;;
 259 ;;;
 260 ;;;
 261 (define (fair-strip-subtask . initial-strips)
 262   (let ((st (make-fair-runq)))
 263     (apply st 'add! initial-strips)
 264     st))
 265
 266 ;;; runq.scm ends here