1 ;;; srfi-18.scm --- Multithreading support
3 ;; Copyright (C) 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
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 3 of the License, or (at your option) any later version.
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.
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
19 ;;; Author: Julian Graham <julian.graham@aya.yale.edu>
24 ;; This is an implementation of SRFI-18 (Multithreading support).
26 ;; All procedures defined in SRFI-18, which are not already defined in
27 ;; the Guile core library, are exported.
29 ;; This module is fully documented in the Guile Reference Manual.
33 (define-module (srfi srfi-18)
34 :use-module (srfi srfi-34)
38 ;; current-thread <= in the core
39 ;; thread? <= in the core
51 ;; mutex? <= in the core
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!
76 current-exception-handler
77 with-exception-handler
79 join-timeout-exception?
80 abandoned-mutex-exception?
81 terminated-thread-exception?
83 uncaught-exception-reason
85 :re-export (thread? mutex? condition-variable?)
86 :replace (current-time
89 make-condition-variable
92 (if (not (provided? 'threads))
93 (error "SRFI-18 requires Guile with threads support"))
95 (cond-expand-provide (current-module) '(srfi-18))
97 (define (check-arg-type pred arg caller)
100 (scm-error 'wrong-type-arg caller
101 "Wrong type argument: ~S" (list arg) '())))
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))
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))
115 (define raise (@ (srfi srfi-34) raise))
116 (define (initial-handler obj)
117 (srfi-18-exception-preserver (cons uncaught-exception obj)))
119 (define thread->exception (make-object-property))
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)))
126 (define (srfi-18-exception-handler key . args)
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'.
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)))))
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)))))
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))
148 ((@ (srfi srfi-34) with-exception-handler)
150 (hashq-set! thread-exception-handlers ct hl)
153 (call-with-values thunk
155 (hashq-set! thread-exception-handlers ct hl)
156 (apply values res)))))))
158 (define (current-exception-handler)
159 (car (current-handler-stack)))
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))
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.
177 (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
180 (signal-condition-variable lcond)
182 (unlock-mutex lmutex)
183 (wait-condition-variable scond smutex)
184 (unlock-mutex smutex)
185 (with-exception-handler initial-handler
187 (lambda (thunk . name)
188 (let ((n (and (pair? name) (car name)))
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)))
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)
204 (define (thread-name thread)
205 (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
207 (define (thread-specific thread)
208 (hashq-ref object-specifics
209 (check-arg-type thread? thread "thread-specific")))
211 (define (thread-specific-set! thread obj)
212 (hashq-set! object-specifics
213 (check-arg-type thread? thread "thread-specific-set!")
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))
222 (hashq-remove! thread-start-conds thread)
224 (signal-condition-variable scond)
225 (unlock-mutex smutex)))
228 (define (thread-yield!) (yield) *unspecified*)
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))
234 (else (scm-error 'wrong-type-arg "thread-sleep!"
235 "Wrong type argument: ~S"
238 (secs (inexact->exact (truncate t)))
239 (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
240 (and (> secs 0) (sleep secs))
241 (and (> usecs 0) (usleep usecs))
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")
251 (lambda (continuation)
252 (with-exception-handler (lambda (obj)
253 ((current-exception-handler) obj)
257 ;; A pass-thru to cancel-thread that first installs a handler that throws
258 ;; terminated-thread exception, as per SRFI-18,
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
266 (with-exception-handler initial-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)
275 (thread-terminate-inner!))
277 (define (thread-join! thread . args)
278 (define thread-join-inner!
280 (let ((v (apply join-thread thread args))
281 (e (thread->exception thread)))
282 (if (and (= (length args) 1) (not v))
283 (raise join-timeout-exception))
286 (call/cc thread-join-inner!))
289 ;; These functions are all pass-thrus to the existing Guile implementations.
293 (let ((n (and (pair? name) (car name)))
294 (m ((@ (guile) make-mutex)
296 'allow-external-unlock
298 (and n (hashq-set! object-names m n)) m)))
300 (define (mutex-name mutex)
301 (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
303 (define (mutex-specific mutex)
304 (hashq-ref object-specifics
305 (check-arg-type mutex? mutex "mutex-specific")))
307 (define (mutex-specific-set! mutex obj)
308 (hashq-set! object-specifics
309 (check-arg-type mutex? mutex "mutex-specific-set!")
313 (define (mutex-state mutex)
314 (let ((owner (mutex-owner mutex)))
316 (if (thread-exited? owner) 'abandoned owner)
317 (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
319 (define (mutex-lock! mutex . args)
320 (define mutex-lock-inner!
322 (catch 'abandoned-mutex-error
323 (lambda () (apply lock-mutex mutex args))
324 (lambda (key . args) (raise abandoned-mutex-exception))))))
325 (call/cc mutex-lock-inner!))
327 (define (mutex-unlock! mutex . args)
328 (apply unlock-mutex mutex args))
330 ;; CONDITION VARIABLES
331 ;; These functions are all pass-thrus to the existing Guile implementations.
333 (define make-condition-variable
335 (let ((n (and (pair? name) (car name)))
336 (m ((@ (guile) make-condition-variable))))
337 (and n (hashq-set! object-names m n)) m)))
339 (define (condition-variable-name condition-variable)
340 (hashq-ref object-names (check-arg-type condition-variable?
342 "condition-variable-name")))
344 (define (condition-variable-specific condition-variable)
345 (hashq-ref object-specifics (check-arg-type condition-variable?
347 "condition-variable-specific")))
349 (define (condition-variable-specific-set! condition-variable obj)
350 (hashq-set! object-specifics
351 (check-arg-type condition-variable?
353 "condition-variable-specific-set!")
357 (define (condition-variable-signal! cond)
358 (signal-condition-variable cond)
361 (define (condition-variable-broadcast! cond)
362 (broadcast-condition-variable cond)
367 (define current-time gettimeofday)
370 (let ((co (car obj))) (and (integer? co) (>= co 0)))
371 (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
373 (define (time->seconds time)
374 (and (check-arg-type time? time "time->seconds")
375 (+ (car time) (/ (cdr time) 1000000))))
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)))))))
383 ;; srfi-18.scm ends here