Commit | Line | Data |
---|---|---|
b046219e JG |
1 | ;;; srfi-18.scm --- Multithreading support |
2 | ||
3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; This library is free software; you can redistribute it and/or | |
6 | ;; modify it under the terms of the GNU Lesser General Public | |
7 | ;; License as published by the Free Software Foundation; either | |
8 | ;; version 2.1 of the License, or (at your option) any later version. | |
9 | ;; | |
10 | ;; This library 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 GNU | |
13 | ;; Lesser General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU Lesser General Public | |
16 | ;; License along with this library; if not, write to the Free Software | |
17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
18 | ||
19 | ;;; Author: Julian Graham <julian.graham@aya.yale.edu> | |
20 | ;;; Date: 2008-04-11 | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
24 | ;; This is an implementation of SRFI-18 (Multithreading support). | |
25 | ;; | |
26 | ;; All procedures defined in SRFI-18, which are not already defined in | |
27 | ;; the Guile core library, are exported. | |
28 | ;; | |
29 | ;; This module is fully documented in the Guile Reference Manual. | |
30 | ||
31 | ;;; Code: | |
32 | ||
33 | (define-module (srfi srfi-18) | |
34 | :use-module (srfi srfi-34) | |
35 | :export ( | |
36 | ||
37 | ;;; Threads | |
38 | ;; current-thread <= in the core | |
39 | ;; thread? <= in the core | |
40 | make-thread | |
41 | thread-name | |
42 | thread-specific | |
43 | thread-specific-set! | |
44 | thread-start! | |
45 | thread-yield! | |
46 | thread-sleep! | |
47 | thread-terminate! | |
48 | thread-join! | |
49 | ||
50 | ;;; Mutexes | |
51 | ;; mutex? <= in the core | |
52 | make-mutex | |
53 | mutex-name | |
54 | mutex-specific | |
55 | mutex-specific-set! | |
56 | mutex-state | |
57 | mutex-lock! | |
58 | mutex-unlock! | |
59 | ||
60 | ;;; Condition variables | |
61 | ;; condition-variable? <= in the core | |
62 | make-condition-variable | |
63 | condition-variable-name | |
64 | condition-variable-specific | |
65 | condition-variable-specific-set! | |
66 | condition-variable-signal! | |
67 | condition-variable-broadcast! | |
68 | condition-variable-wait! | |
69 | ||
70 | ;;; Time | |
71 | current-time | |
72 | time? | |
73 | time->seconds | |
74 | seconds->time | |
75 | ||
76 | current-exception-handler | |
77 | with-exception-handler | |
78 | raise | |
79 | join-timeout-exception? | |
80 | abandoned-mutex-exception? | |
81 | terminated-thread-exception? | |
82 | uncaught-exception? | |
83 | uncaught-exception-reason | |
84 | ) | |
85 | :re-export (thread? mutex? condition-variable?) | |
86 | :replace (current-time | |
87 | make-thread | |
88 | make-mutex | |
89 | make-condition-variable | |
90 | raise)) | |
91 | ||
d0b6ad34 JG |
92 | (if (not (provided? 'threads)) |
93 | (error "SRFI-18 requires Guile with threads support")) | |
94 | ||
b046219e JG |
95 | (cond-expand-provide (current-module) '(srfi-18)) |
96 | ||
97 | (define (check-arg-type pred arg caller) | |
98 | (if (pred arg) | |
99 | arg | |
100 | (scm-error 'wrong-type-arg caller | |
101 | "Wrong type argument: ~S" (list arg) '()))) | |
102 | ||
103 | (define abandoned-mutex-exception (list 'abandoned-mutex-exception)) | |
104 | (define join-timeout-exception (list 'join-timeout-exception)) | |
105 | (define terminated-thread-exception (list 'terminated-thread-exception)) | |
106 | (define uncaught-exception (list 'uncaught-exception)) | |
107 | ||
108 | (define mutex-owners (make-weak-key-hash-table)) | |
109 | (define object-names (make-weak-key-hash-table)) | |
110 | (define object-specifics (make-weak-key-hash-table)) | |
111 | (define thread-start-conds (make-weak-key-hash-table)) | |
112 | (define thread-exception-handlers (make-weak-key-hash-table)) | |
113 | ||
114 | ;; EXCEPTIONS | |
115 | ||
116 | (define raise (@ (srfi srfi-34) raise)) | |
117 | (define (initial-handler obj) | |
118 | (srfi-18-exception-preserver (cons uncaught-exception obj))) | |
119 | ||
120 | (define thread->exception (make-object-property)) | |
121 | ||
122 | (define (srfi-18-exception-preserver obj) | |
123 | (if (or (terminated-thread-exception? obj) | |
124 | (uncaught-exception? obj)) | |
125 | (set! (thread->exception (current-thread)) obj))) | |
126 | ||
127 | (define (srfi-18-exception-handler key . args) | |
128 | ||
129 | ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so | |
130 | ;; if one is caught at this level, it has already been taken care of by | |
131 | ;; `initial-handler'. | |
132 | ||
133 | (and (not (eq? key 'srfi-34)) | |
134 | (srfi-18-exception-preserver (if (null? args) | |
135 | (cons uncaught-exception key) | |
136 | (cons* uncaught-exception key args))))) | |
137 | ||
138 | (define (current-handler-stack) | |
139 | (let ((ct (current-thread))) | |
140 | (or (hashq-ref thread-exception-handlers ct) | |
141 | (hashq-set! thread-exception-handlers ct (list initial-handler))))) | |
142 | ||
143 | (define (with-exception-handler handler thunk) | |
144 | (let ((ct (current-thread)) | |
145 | (hl (current-handler-stack))) | |
146 | (check-arg-type procedure? handler "with-exception-handler") | |
147 | (check-arg-type thunk? thunk "with-exception-handler") | |
148 | (hashq-set! thread-exception-handlers ct (cons handler hl)) | |
149 | (apply (@ (srfi srfi-34) with-exception-handler) | |
150 | (list (lambda (obj) | |
151 | (hashq-set! thread-exception-handlers ct hl) | |
152 | (handler obj)) | |
153 | (lambda () | |
154 | (let ((r (thunk))) | |
155 | (hashq-set! thread-exception-handlers ct hl) r)))))) | |
156 | ||
157 | (define (current-exception-handler) | |
158 | (car (current-handler-stack))) | |
159 | ||
160 | (define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) | |
161 | (define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) | |
162 | (define (uncaught-exception? obj) | |
163 | (and (pair? obj) (eq? (car obj) uncaught-exception))) | |
164 | (define (uncaught-exception-reason exc) | |
165 | (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason"))) | |
166 | (define (terminated-thread-exception? obj) | |
167 | (eq? obj terminated-thread-exception)) | |
168 | ||
169 | ;; THREADS | |
170 | ||
171 | ;; Create a new thread and prevent it from starting using a condition variable. | |
172 | ;; Once started, install a top-level exception handler that rethrows any | |
173 | ;; exceptions wrapped in an uncaught-exception wrapper. | |
174 | ||
175 | (define make-thread | |
176 | (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) | |
177 | (lambda () | |
178 | (lock-mutex lmutex) | |
179 | (signal-condition-variable lcond) | |
180 | (lock-mutex smutex) | |
181 | (unlock-mutex lmutex) | |
182 | (wait-condition-variable scond smutex) | |
183 | (unlock-mutex smutex) | |
184 | (with-exception-handler initial-handler | |
185 | thunk))))) | |
186 | (lambda (thunk . name) | |
187 | (let ((n (and (pair? name) (car name))) | |
188 | ||
189 | (lm (make-mutex 'launch-mutex)) | |
190 | (lc (make-condition-variable 'launch-condition-variable)) | |
191 | (sm (make-mutex 'start-mutex)) | |
192 | (sc (make-condition-variable 'start-condition-variable))) | |
193 | ||
194 | (lock-mutex lm) | |
195 | (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm) | |
196 | srfi-18-exception-handler))) | |
197 | (hashq-set! thread-start-conds t (cons sm sc)) | |
198 | (and n (hashq-set! object-names t n)) | |
199 | (wait-condition-variable lc lm) | |
200 | (unlock-mutex lm) | |
201 | t))))) | |
202 | ||
203 | (define (thread-name thread) | |
204 | (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) | |
205 | ||
206 | (define (thread-specific thread) | |
207 | (hashq-ref object-specifics | |
208 | (check-arg-type thread? thread "thread-specific"))) | |
209 | ||
210 | (define (thread-specific-set! thread obj) | |
211 | (hashq-set! object-specifics | |
212 | (check-arg-type thread? thread "thread-specific-set!") | |
213 | obj) | |
214 | *unspecified*) | |
215 | ||
216 | (define (thread-start! thread) | |
217 | (let ((x (hashq-ref thread-start-conds | |
218 | (check-arg-type thread? thread "thread-start!")))) | |
219 | (and x (let ((smutex (car x)) | |
220 | (scond (cdr x))) | |
221 | (hashq-remove! thread-start-conds thread) | |
222 | (lock-mutex smutex) | |
223 | (signal-condition-variable scond) | |
224 | (unlock-mutex smutex))) | |
225 | thread)) | |
226 | ||
227 | (define (thread-yield!) (yield) *unspecified*) | |
228 | ||
229 | (define (thread-sleep! timeout) | |
230 | (let* ((ct (time->seconds (current-time))) | |
231 | (t (cond ((time? timeout) (- (time->seconds timeout) ct)) | |
232 | ((number? timeout) (- timeout ct)) | |
233 | (else (scm-error 'wrong-type-arg caller | |
234 | "Wrong type argument: ~S" | |
235 | (list timeout) | |
236 | '())))) | |
237 | (secs (inexact->exact (truncate t))) | |
238 | (usecs (inexact->exact (truncate (* (- t secs) 1000))))) | |
239 | (and (> secs 0) (sleep secs)) | |
240 | (and (> usecs 0) (usleep usecs)) | |
241 | *unspecified*)) | |
242 | ||
243 | ;; A convenience function for installing exception handlers on SRFI-18 | |
244 | ;; primitives that resume the calling continuation after the handler is | |
245 | ;; invoked -- this resolves a behavioral incompatibility with Guile's | |
246 | ;; implementation of SRFI-34, which uses lazy-catch and rethrows handled | |
247 | ;; exceptions. (SRFI-18, "Primitives and exceptions") | |
248 | ||
249 | (define (wrap thunk) | |
250 | (lambda (continuation) | |
251 | (with-exception-handler (lambda (obj) | |
252 | (apply (current-exception-handler) (list obj)) | |
253 | (apply continuation (list))) | |
254 | thunk))) | |
255 | ||
256 | ;; A pass-thru to cancel-thread that first installs a handler that throws | |
257 | ;; terminated-thread exception, as per SRFI-18, | |
258 | ||
259 | (define (thread-terminate! thread) | |
260 | (define (thread-terminate-inner!) | |
261 | (let ((current-handler (thread-cleanup thread))) | |
262 | (if (thunk? current-handler) | |
263 | (set-thread-cleanup! thread | |
264 | (lambda () | |
265 | (with-exception-handler initial-handler | |
266 | current-handler) | |
267 | (srfi-18-exception-preserver | |
268 | terminated-thread-exception))) | |
269 | (set-thread-cleanup! thread | |
270 | (lambda () (srfi-18-exception-preserver | |
271 | terminated-thread-exception)))) | |
272 | (cancel-thread thread) | |
273 | *unspecified*)) | |
274 | (thread-terminate-inner!)) | |
275 | ||
276 | (define (thread-join! thread . args) | |
277 | (define thread-join-inner! | |
278 | (wrap (lambda () | |
279 | (let ((v (apply join-thread (cons thread args))) | |
280 | (e (thread->exception thread))) | |
281 | (if (and (= (length args) 1) (not v)) | |
282 | (raise join-timeout-exception)) | |
283 | (if e (raise e)) | |
284 | v)))) | |
285 | (call/cc thread-join-inner!)) | |
286 | ||
287 | ;; MUTEXES | |
288 | ;; These functions are all pass-thrus to the existing Guile implementations. | |
289 | ||
290 | (define make-mutex | |
291 | (lambda name | |
292 | (let ((n (and (pair? name) (car name))) | |
293 | (m ((@ (guile) make-mutex) | |
294 | 'unchecked-unlock | |
295 | 'allow-external-unlock | |
296 | 'recursive))) | |
297 | (and n (hashq-set! object-names m n)) m))) | |
298 | ||
299 | (define (mutex-name mutex) | |
300 | (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name"))) | |
301 | ||
302 | (define (mutex-specific mutex) | |
303 | (hashq-ref object-specifics | |
304 | (check-arg-type mutex? mutex "mutex-specific"))) | |
305 | ||
306 | (define (mutex-specific-set! mutex obj) | |
307 | (hashq-set! object-specifics | |
308 | (check-arg-type mutex? mutex "mutex-specific-set!") | |
309 | obj) | |
310 | *unspecified*) | |
311 | ||
312 | (define (mutex-state mutex) | |
313 | (let ((owner (mutex-owner mutex))) | |
314 | (if owner | |
315 | (if (thread-exited? owner) 'abandoned owner) | |
316 | (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned)))) | |
317 | ||
318 | (define (mutex-lock! mutex . args) | |
319 | (define mutex-lock-inner! | |
320 | (wrap (lambda () | |
321 | (catch 'abandoned-mutex-error | |
322 | (lambda () (apply lock-mutex (cons mutex args))) | |
323 | (lambda (key . args) (raise abandoned-mutex-exception)))))) | |
324 | (call/cc mutex-lock-inner!)) | |
325 | ||
326 | (define (mutex-unlock! mutex . args) | |
327 | (apply unlock-mutex (cons mutex args))) | |
328 | ||
329 | ;; CONDITION VARIABLES | |
330 | ;; These functions are all pass-thrus to the existing Guile implementations. | |
331 | ||
332 | (define make-condition-variable | |
333 | (lambda name | |
334 | (let ((n (and (pair? name) (car name))) | |
335 | (m ((@ (guile) make-condition-variable)))) | |
336 | (and n (hashq-set! object-names m n)) m))) | |
337 | ||
338 | (define (condition-variable-name condition-variable) | |
339 | (hashq-ref object-names (check-arg-type condition-variable? | |
340 | condition-variable | |
341 | "condition-variable-name"))) | |
342 | ||
343 | (define (condition-variable-specific condition-variable) | |
344 | (hashq-ref object-specifics (check-arg-type condition-variable? | |
345 | condition-variable | |
346 | "condition-variable-specific"))) | |
347 | ||
348 | (define (condition-variable-specific-set! condition-variable obj) | |
349 | (hashq-set! object-specifics | |
350 | (check-arg-type condition-variable? | |
351 | condition-variable | |
352 | "condition-variable-specific-set!") | |
353 | obj) | |
354 | *unspecified*) | |
355 | ||
356 | (define (condition-variable-signal! cond) | |
357 | (signal-condition-variable cond) | |
358 | *unspecified*) | |
359 | ||
360 | (define (condition-variable-broadcast! cond) | |
361 | (broadcast-condition-variable cond) | |
362 | *unspecified*) | |
363 | ||
364 | ;; TIME | |
365 | ||
366 | (define current-time gettimeofday) | |
367 | (define (time? obj) | |
368 | (and (pair? obj) | |
369 | (let ((co (car obj))) (and (integer? co) (>= co 0))) | |
370 | (let ((co (cdr obj))) (and (integer? co) (>= co 0))))) | |
371 | ||
372 | (define (time->seconds time) | |
373 | (and (check-arg-type time? time "time->seconds") | |
374 | (+ (car time) (/ (cdr time) 1000000)))) | |
375 | ||
376 | (define (seconds->time x) | |
377 | (and (check-arg-type number? x "seconds->time") | |
378 | (let ((fx (truncate x))) | |
379 | (cons (inexact->exact fx) | |
380 | (inexact->exact (truncate (* (- x fx) 1000000))))))) | |
381 | ||
382 | ;; srfi-18.scm ends here |