Commit | Line | Data |
---|---|---|
6a4d3cfd JB |
1 | ;;;; runq.scm --- the runq data structure |
2 | ;;;; | |
64705682 TTN |
3 | ;;;; Copyright (C) 1996, 2001 Free Software Foundation, Inc. |
4 | ;;;; | |
a6401ee0 JB |
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. | |
64705682 | 9 | ;;;; |
a6401ee0 JB |
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. | |
64705682 | 14 | ;;;; |
a6401ee0 JB |
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 | |
64705682 | 19 | ;;;; |
a482f2cc MV |
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 | ;;;; | |
a6401ee0 | 44 | |
64705682 | 45 | ;;; Commentary: |
6a4d3cfd | 46 | |
a6401ee0 JB |
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. | |
64705682 | 52 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 56 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 61 | ;;; |
a6401ee0 JB |
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.) | |
a6401ee0 | 71 | |
64705682 | 72 | ;;; Code: |
a6401ee0 | 73 | |
64705682 | 74 | (define-module (ice-9 runq) |
1a179b03 MD |
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)) | |
a6401ee0 JB |
79 | |
80 | ;;;; | |
81 | ;;; (runq-control q msg . args) | |
64705682 | 82 | ;;; |
a6401ee0 JB |
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). | |
64705682 | 86 | ;;; |
a6401ee0 | 87 | ;;; The standard runq messages are: |
64705682 | 88 | ;;; |
a6401ee0 JB |
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 | |
64705682 | 96 | ;;; |
1a179b03 | 97 | (define (runq-control q msg . args) |
a6401ee0 JB |
98 | (case msg |
99 | ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) | |
608cf70c | 100 | ((enqueue!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) |
a6401ee0 JB |
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 | ;;; | |
1a179b03 | 115 | (define (make-void-runq) |
a6401ee0 JB |
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 | ||
64705682 | 124 | ;;;; |
a6401ee0 | 125 | ;;; (make-fair-runq) |
64705682 | 126 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 130 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 134 | ;;; |
1a179b03 | 135 | (define (make-fair-runq) |
a6401ee0 | 136 | (letrec ((q (make-q)) |
64705682 | 137 | (self |
a6401ee0 JB |
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 | ||
64705682 | 154 | ;;;; |
a6401ee0 | 155 | ;;; (make-exclusive-runq) |
64705682 | 156 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 160 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 164 | ;;; |
a6401ee0 JB |
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. | |
64705682 | 170 | ;;; |
1a179b03 | 171 | (define (make-exclusive-runq) |
a6401ee0 | 172 | (letrec ((q (make-q)) |
64705682 | 173 | (self |
a6401ee0 JB |
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 | ||
64705682 | 190 | ;;;; |
a6401ee0 | 191 | ;;; (make-subordinate-runq-to superior basic-inferior) |
64705682 | 192 | ;;; |
a6401ee0 | 193 | ;;; Returns a runq proxy for the runq basic-inferior. |
64705682 | 194 | ;;; |
a6401ee0 | 195 | ;;; The proxy watches for operations on the basic-inferior that cause |
64705682 | 196 | ;;; a transition from a queue length of 0 to a non-zero length and |
a6401ee0 JB |
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 | |
64705682 TTN |
201 | ;;; strip is entered. [Countless scheduling variations are possible.] |
202 | ;;; | |
1a179b03 | 203 | (define (make-subordinate-runq-to superior-runq basic-runq) |
a6401ee0 JB |
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)) | |
64705682 | 231 | ;;; Return a strip that starts several strips in |
a6401ee0 JB |
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 | ||
64705682 | 239 | ;;;; |
a6401ee0 | 240 | ;;; (strip-sequence . strips) |
64705682 | 241 | ;;; |
a6401ee0 | 242 | ;;; Returns a new strip which is the concatenation of the argument strips. |
64705682 | 243 | ;;; |
1a179b03 | 244 | (define ((strip-sequence . strips)) |
a6401ee0 JB |
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) | |
64705682 | 255 | ;;; |
a6401ee0 JB |
256 | ;;; Returns a new strip which is the synchronos, fair, |
257 | ;;; parallel execution of the argument strips. | |
64705682 TTN |
258 | ;;; |
259 | ;;; | |
a6401ee0 | 260 | ;;; |
1a179b03 | 261 | (define (fair-strip-subtask . initial-strips) |
a6401ee0 JB |
262 | (let ((st (make-fair-runq))) |
263 | (apply st 'add! initial-strips) | |
264 | st)) | |
265 | ||
64705682 | 266 | ;;; runq.scm ends here |