Commit | Line | Data |
---|---|---|
b046219e JG |
1 | ;;; srfi-18.scm --- Multithreading support |
2 | ||
475772ea | 3 | ;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc. |
b046219e JG |
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 | |
83ba2d37 | 8 | ;; version 3 of the License, or (at your option) any later version. |
b046219e JG |
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 | ) | |
6587bcfa | 85 | :re-export (current-thread thread? mutex? condition-variable?) |
b046219e JG |
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 | ||
b046219e JG |
108 | (define object-names (make-weak-key-hash-table)) |
109 | (define object-specifics (make-weak-key-hash-table)) | |
110 | (define thread-start-conds (make-weak-key-hash-table)) | |
111 | (define thread-exception-handlers (make-weak-key-hash-table)) | |
112 | ||
113 | ;; EXCEPTIONS | |
114 | ||
115 | (define raise (@ (srfi srfi-34) raise)) | |
116 | (define (initial-handler obj) | |
117 | (srfi-18-exception-preserver (cons uncaught-exception obj))) | |
118 | ||
119 | (define thread->exception (make-object-property)) | |
120 | ||
121 | (define (srfi-18-exception-preserver obj) | |
122 | (if (or (terminated-thread-exception? obj) | |
123 | (uncaught-exception? obj)) | |
124 | (set! (thread->exception (current-thread)) obj))) | |
125 | ||
126 | (define (srfi-18-exception-handler key . args) | |
127 | ||
128 | ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so | |
129 | ;; if one is caught at this level, it has already been taken care of by | |
130 | ;; `initial-handler'. | |
131 | ||
132 | (and (not (eq? key 'srfi-34)) | |
133 | (srfi-18-exception-preserver (if (null? args) | |
134 | (cons uncaught-exception key) | |
135 | (cons* uncaught-exception key args))))) | |
136 | ||
137 | (define (current-handler-stack) | |
138 | (let ((ct (current-thread))) | |
139 | (or (hashq-ref thread-exception-handlers ct) | |
140 | (hashq-set! thread-exception-handlers ct (list initial-handler))))) | |
141 | ||
142 | (define (with-exception-handler handler thunk) | |
143 | (let ((ct (current-thread)) | |
144 | (hl (current-handler-stack))) | |
145 | (check-arg-type procedure? handler "with-exception-handler") | |
146 | (check-arg-type thunk? thunk "with-exception-handler") | |
147 | (hashq-set! thread-exception-handlers ct (cons handler hl)) | |
f9c35841 AW |
148 | ((@ (srfi srfi-34) with-exception-handler) |
149 | (lambda (obj) | |
150 | (hashq-set! thread-exception-handlers ct hl) | |
151 | (handler obj)) | |
152 | (lambda () | |
153 | (call-with-values thunk | |
154 | (lambda res | |
155 | (hashq-set! thread-exception-handlers ct hl) | |
156 | (apply values res))))))) | |
b046219e JG |
157 | |
158 | (define (current-exception-handler) | |
159 | (car (current-handler-stack))) | |
160 | ||
161 | (define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) | |
162 | (define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) | |
163 | (define (uncaught-exception? obj) | |
164 | (and (pair? obj) (eq? (car obj) uncaught-exception))) | |
165 | (define (uncaught-exception-reason exc) | |
166 | (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason"))) | |
167 | (define (terminated-thread-exception? obj) | |
168 | (eq? obj terminated-thread-exception)) | |
169 | ||
170 | ;; THREADS | |
171 | ||
172 | ;; Create a new thread and prevent it from starting using a condition variable. | |
173 | ;; Once started, install a top-level exception handler that rethrows any | |
174 | ;; exceptions wrapped in an uncaught-exception wrapper. | |
175 | ||
176 | (define make-thread | |
177 | (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) | |
178 | (lambda () | |
179 | (lock-mutex lmutex) | |
180 | (signal-condition-variable lcond) | |
181 | (lock-mutex smutex) | |
182 | (unlock-mutex lmutex) | |
183 | (wait-condition-variable scond smutex) | |
184 | (unlock-mutex smutex) | |
185 | (with-exception-handler initial-handler | |
186 | thunk))))) | |
187 | (lambda (thunk . name) | |
188 | (let ((n (and (pair? name) (car name))) | |
189 | ||
190 | (lm (make-mutex 'launch-mutex)) | |
191 | (lc (make-condition-variable 'launch-condition-variable)) | |
192 | (sm (make-mutex 'start-mutex)) | |
193 | (sc (make-condition-variable 'start-condition-variable))) | |
194 | ||
195 | (lock-mutex lm) | |
196 | (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm) | |
197 | srfi-18-exception-handler))) | |
198 | (hashq-set! thread-start-conds t (cons sm sc)) | |
199 | (and n (hashq-set! object-names t n)) | |
200 | (wait-condition-variable lc lm) | |
201 | (unlock-mutex lm) | |
202 | t))))) | |
203 | ||
204 | (define (thread-name thread) | |
205 | (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) | |
206 | ||
207 | (define (thread-specific thread) | |
208 | (hashq-ref object-specifics | |
209 | (check-arg-type thread? thread "thread-specific"))) | |
210 | ||
211 | (define (thread-specific-set! thread obj) | |
212 | (hashq-set! object-specifics | |
213 | (check-arg-type thread? thread "thread-specific-set!") | |
214 | obj) | |
215 | *unspecified*) | |
216 | ||
217 | (define (thread-start! thread) | |
218 | (let ((x (hashq-ref thread-start-conds | |
219 | (check-arg-type thread? thread "thread-start!")))) | |
220 | (and x (let ((smutex (car x)) | |
221 | (scond (cdr x))) | |
222 | (hashq-remove! thread-start-conds thread) | |
223 | (lock-mutex smutex) | |
224 | (signal-condition-variable scond) | |
225 | (unlock-mutex smutex))) | |
226 | thread)) | |
227 | ||
228 | (define (thread-yield!) (yield) *unspecified*) | |
229 | ||
230 | (define (thread-sleep! timeout) | |
231 | (let* ((ct (time->seconds (current-time))) | |
232 | (t (cond ((time? timeout) (- (time->seconds timeout) ct)) | |
233 | ((number? timeout) (- timeout ct)) | |
84012ef4 | 234 | (else (scm-error 'wrong-type-arg "thread-sleep!" |
b046219e JG |
235 | "Wrong type argument: ~S" |
236 | (list timeout) | |
237 | '())))) | |
238 | (secs (inexact->exact (truncate t))) | |
8d124d20 | 239 | (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) |
b046219e JG |
240 | (and (> secs 0) (sleep secs)) |
241 | (and (> usecs 0) (usleep usecs)) | |
242 | *unspecified*)) | |
243 | ||
244 | ;; A convenience function for installing exception handlers on SRFI-18 | |
245 | ;; primitives that resume the calling continuation after the handler is | |
246 | ;; invoked -- this resolves a behavioral incompatibility with Guile's | |
247 | ;; implementation of SRFI-34, which uses lazy-catch and rethrows handled | |
248 | ;; exceptions. (SRFI-18, "Primitives and exceptions") | |
249 | ||
250 | (define (wrap thunk) | |
251 | (lambda (continuation) | |
252 | (with-exception-handler (lambda (obj) | |
30a5e062 AW |
253 | ((current-exception-handler) obj) |
254 | (continuation)) | |
b046219e JG |
255 | thunk))) |
256 | ||
257 | ;; A pass-thru to cancel-thread that first installs a handler that throws | |
258 | ;; terminated-thread exception, as per SRFI-18, | |
259 | ||
260 | (define (thread-terminate! thread) | |
261 | (define (thread-terminate-inner!) | |
262 | (let ((current-handler (thread-cleanup thread))) | |
263 | (if (thunk? current-handler) | |
264 | (set-thread-cleanup! thread | |
265 | (lambda () | |
266 | (with-exception-handler initial-handler | |
267 | current-handler) | |
268 | (srfi-18-exception-preserver | |
269 | terminated-thread-exception))) | |
270 | (set-thread-cleanup! thread | |
271 | (lambda () (srfi-18-exception-preserver | |
272 | terminated-thread-exception)))) | |
273 | (cancel-thread thread) | |
274 | *unspecified*)) | |
275 | (thread-terminate-inner!)) | |
276 | ||
277 | (define (thread-join! thread . args) | |
278 | (define thread-join-inner! | |
279 | (wrap (lambda () | |
f9c35841 | 280 | (let ((v (apply join-thread thread args)) |
b046219e JG |
281 | (e (thread->exception thread))) |
282 | (if (and (= (length args) 1) (not v)) | |
283 | (raise join-timeout-exception)) | |
284 | (if e (raise e)) | |
285 | v)))) | |
286 | (call/cc thread-join-inner!)) | |
287 | ||
288 | ;; MUTEXES | |
289 | ;; These functions are all pass-thrus to the existing Guile implementations. | |
290 | ||
291 | (define make-mutex | |
292 | (lambda name | |
293 | (let ((n (and (pair? name) (car name))) | |
294 | (m ((@ (guile) make-mutex) | |
295 | 'unchecked-unlock | |
296 | 'allow-external-unlock | |
297 | 'recursive))) | |
298 | (and n (hashq-set! object-names m n)) m))) | |
299 | ||
300 | (define (mutex-name mutex) | |
301 | (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name"))) | |
302 | ||
303 | (define (mutex-specific mutex) | |
304 | (hashq-ref object-specifics | |
305 | (check-arg-type mutex? mutex "mutex-specific"))) | |
306 | ||
307 | (define (mutex-specific-set! mutex obj) | |
308 | (hashq-set! object-specifics | |
309 | (check-arg-type mutex? mutex "mutex-specific-set!") | |
310 | obj) | |
311 | *unspecified*) | |
312 | ||
313 | (define (mutex-state mutex) | |
314 | (let ((owner (mutex-owner mutex))) | |
315 | (if owner | |
316 | (if (thread-exited? owner) 'abandoned owner) | |
317 | (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned)))) | |
318 | ||
319 | (define (mutex-lock! mutex . args) | |
320 | (define mutex-lock-inner! | |
321 | (wrap (lambda () | |
322 | (catch 'abandoned-mutex-error | |
f9c35841 | 323 | (lambda () (apply lock-mutex mutex args)) |
b046219e JG |
324 | (lambda (key . args) (raise abandoned-mutex-exception)))))) |
325 | (call/cc mutex-lock-inner!)) | |
326 | ||
327 | (define (mutex-unlock! mutex . args) | |
f9c35841 | 328 | (apply unlock-mutex mutex args)) |
b046219e JG |
329 | |
330 | ;; CONDITION VARIABLES | |
331 | ;; These functions are all pass-thrus to the existing Guile implementations. | |
332 | ||
333 | (define make-condition-variable | |
334 | (lambda name | |
335 | (let ((n (and (pair? name) (car name))) | |
336 | (m ((@ (guile) make-condition-variable)))) | |
337 | (and n (hashq-set! object-names m n)) m))) | |
338 | ||
339 | (define (condition-variable-name condition-variable) | |
340 | (hashq-ref object-names (check-arg-type condition-variable? | |
341 | condition-variable | |
342 | "condition-variable-name"))) | |
343 | ||
344 | (define (condition-variable-specific condition-variable) | |
345 | (hashq-ref object-specifics (check-arg-type condition-variable? | |
346 | condition-variable | |
347 | "condition-variable-specific"))) | |
348 | ||
349 | (define (condition-variable-specific-set! condition-variable obj) | |
350 | (hashq-set! object-specifics | |
351 | (check-arg-type condition-variable? | |
352 | condition-variable | |
353 | "condition-variable-specific-set!") | |
354 | obj) | |
355 | *unspecified*) | |
356 | ||
357 | (define (condition-variable-signal! cond) | |
358 | (signal-condition-variable cond) | |
359 | *unspecified*) | |
360 | ||
361 | (define (condition-variable-broadcast! cond) | |
362 | (broadcast-condition-variable cond) | |
363 | *unspecified*) | |
364 | ||
365 | ;; TIME | |
366 | ||
367 | (define current-time gettimeofday) | |
368 | (define (time? obj) | |
369 | (and (pair? obj) | |
370 | (let ((co (car obj))) (and (integer? co) (>= co 0))) | |
371 | (let ((co (cdr obj))) (and (integer? co) (>= co 0))))) | |
372 | ||
373 | (define (time->seconds time) | |
374 | (and (check-arg-type time? time "time->seconds") | |
375 | (+ (car time) (/ (cdr time) 1000000)))) | |
376 | ||
377 | (define (seconds->time x) | |
378 | (and (check-arg-type number? x "seconds->time") | |
379 | (let ((fx (truncate x))) | |
380 | (cons (inexact->exact fx) | |
381 | (inexact->exact (truncate (* (- x fx) 1000000))))))) | |
382 | ||
6587bcfa | 383 | ;; srfi-18.scm ends here |