mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 13:00:26 +02:00
* module/srfi/srfi-18.scm (%cancel-sentinel, thread-terminate!): Just use cancel-thread to cause the thread to return a sentinel value. (%timeout-sentinel): Rename from %sentinel. (thread-join!): Adapt and transform %cancel-sentinel to a &terminated-thread-exception.
353 lines
12 KiB
Scheme
353 lines
12 KiB
Scheme
;;; srfi-18.scm --- Multithreading support
|
|
|
|
;; Copyright (C) 2008, 2009, 2010, 2012, 2014 Free Software Foundation, Inc.
|
|
;;
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 3 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public
|
|
;; License along with this library; if not, write to the Free Software
|
|
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Author: Julian Graham <julian.graham@aya.yale.edu>
|
|
;;; Date: 2008-04-11
|
|
|
|
;;; Commentary:
|
|
|
|
;; This is an implementation of SRFI-18 (Multithreading support).
|
|
;;
|
|
;; All procedures defined in SRFI-18, which are not already defined in
|
|
;; the Guile core library, are exported.
|
|
;;
|
|
;; This module is fully documented in the Guile Reference Manual.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (srfi srfi-18)
|
|
#:use-module ((ice-9 threads) #:prefix threads:)
|
|
#:use-module (ice-9 match)
|
|
#:use-module ((srfi srfi-34) #:prefix srfi-34:)
|
|
#:use-module ((srfi srfi-35) #:select (define-condition-type
|
|
&error
|
|
condition))
|
|
#:export (;; Threads
|
|
make-thread
|
|
thread-name
|
|
thread-specific
|
|
thread-specific-set!
|
|
thread-start!
|
|
thread-yield!
|
|
thread-sleep!
|
|
thread-terminate!
|
|
thread-join!
|
|
|
|
;; Mutexes
|
|
make-mutex
|
|
mutex-name
|
|
mutex-specific
|
|
mutex-specific-set!
|
|
mutex-state
|
|
mutex-lock!
|
|
mutex-unlock!
|
|
|
|
;; Condition variables
|
|
make-condition-variable
|
|
condition-variable-name
|
|
condition-variable-specific
|
|
condition-variable-specific-set!
|
|
condition-variable-signal!
|
|
condition-variable-broadcast!
|
|
condition-variable-wait!
|
|
|
|
;; Time
|
|
current-time
|
|
time?
|
|
time->seconds
|
|
seconds->time
|
|
|
|
current-exception-handler
|
|
with-exception-handler
|
|
join-timeout-exception?
|
|
abandoned-mutex-exception?
|
|
terminated-thread-exception?
|
|
uncaught-exception?
|
|
uncaught-exception-reason)
|
|
#:re-export ((threads:condition-variable? . condition-variable?)
|
|
(threads:current-thread . current-thread)
|
|
(threads:thread? . thread?)
|
|
(threads:mutex? . mutex?)
|
|
(srfi-34:raise . raise))
|
|
#:replace (current-time
|
|
make-thread
|
|
make-mutex
|
|
make-condition-variable))
|
|
|
|
(unless (provided? 'threads)
|
|
(error "SRFI-18 requires Guile with threads support"))
|
|
|
|
(cond-expand-provide (current-module) '(srfi-18))
|
|
|
|
(define (check-arg-type pred arg caller)
|
|
(if (pred arg)
|
|
arg
|
|
(scm-error 'wrong-type-arg caller
|
|
"Wrong type argument: ~S" (list arg) '())))
|
|
|
|
(define-condition-type &abandoned-mutex-exception &error
|
|
abandoned-mutex-exception?)
|
|
(define-condition-type &join-timeout-exception &error
|
|
join-timeout-exception?)
|
|
(define-condition-type &terminated-thread-exception &error
|
|
terminated-thread-exception?)
|
|
(define-condition-type &uncaught-exception &error
|
|
uncaught-exception?
|
|
(reason uncaught-exception-reason))
|
|
|
|
(define object-names (make-weak-key-hash-table))
|
|
(define object-specifics (make-weak-key-hash-table))
|
|
(define thread-start-conds (make-weak-key-hash-table))
|
|
(define thread->exception (make-object-property))
|
|
|
|
;; EXCEPTIONS
|
|
|
|
;; All threads created by SRFI-18 have an initial handler installed that
|
|
;; will squirrel away an uncaught exception to allow it to bubble out to
|
|
;; joining threads. However for the main thread and other threads not
|
|
;; created by SRFI-18, just let the exception bubble up by passing on
|
|
;; doing anything with the exception.
|
|
(define (exception-handler-for-foreign-threads obj)
|
|
(values))
|
|
|
|
(define current-exception-handler
|
|
(make-parameter exception-handler-for-foreign-threads))
|
|
|
|
(define (with-exception-handler handler thunk)
|
|
(check-arg-type procedure? handler "with-exception-handler")
|
|
(check-arg-type thunk? thunk "with-exception-handler")
|
|
(srfi-34:with-exception-handler
|
|
(let ((prev-handler (current-exception-handler)))
|
|
(lambda (obj)
|
|
(parameterize ((current-exception-handler prev-handler))
|
|
(handler obj))))
|
|
(lambda ()
|
|
(parameterize ((current-exception-handler handler))
|
|
(thunk)))))
|
|
|
|
;; THREADS
|
|
|
|
;; Create a new thread and prevent it from starting using a condition variable.
|
|
;; Once started, install a top-level exception handler that rethrows any
|
|
;; exceptions wrapped in an uncaught-exception wrapper.
|
|
|
|
(define* (make-thread thunk #:optional name)
|
|
(let ((sm (make-mutex 'start-mutex))
|
|
(sc (make-condition-variable 'start-condition-variable)))
|
|
(threads:lock-mutex sm)
|
|
(let ((t (threads:call-with-new-thread
|
|
(lambda ()
|
|
(threads:lock-mutex sm)
|
|
(threads:signal-condition-variable sc)
|
|
(threads:wait-condition-variable sc sm)
|
|
(threads:unlock-mutex sm)
|
|
(thunk))
|
|
(lambda (key . args)
|
|
(set! (thread->exception (threads:current-thread))
|
|
(condition (&uncaught-exception
|
|
(reason
|
|
(match (cons key args)
|
|
(('srfi-34 obj) obj)
|
|
(obj obj))))))))))
|
|
(when name (hashq-set! object-names t name))
|
|
(threads:wait-condition-variable sc sm)
|
|
(hashq-set! thread-start-conds t (cons sm sc))
|
|
(threads:unlock-mutex sm)
|
|
t)))
|
|
|
|
(define (thread-name thread)
|
|
(hashq-ref object-names
|
|
(check-arg-type threads:thread? thread "thread-name")))
|
|
|
|
(define (thread-specific thread)
|
|
(hashq-ref object-specifics
|
|
(check-arg-type threads:thread? thread "thread-specific")))
|
|
|
|
(define (thread-specific-set! thread obj)
|
|
(hashq-set! object-specifics
|
|
(check-arg-type threads:thread? thread "thread-specific-set!")
|
|
obj)
|
|
*unspecified*)
|
|
|
|
(define (thread-start! thread)
|
|
(match (hashq-ref thread-start-conds
|
|
(check-arg-type threads:thread? thread "thread-start!"))
|
|
((smutex . scond)
|
|
(hashq-remove! thread-start-conds thread)
|
|
(threads:lock-mutex smutex)
|
|
(threads:signal-condition-variable scond)
|
|
(threads:unlock-mutex smutex))
|
|
(#f #f))
|
|
thread)
|
|
|
|
(define (thread-yield!) (threads:yield) *unspecified*)
|
|
|
|
(define (thread-sleep! timeout)
|
|
(let* ((ct (time->seconds (current-time)))
|
|
(t (cond ((time? timeout) (- (time->seconds timeout) ct))
|
|
((number? timeout) (- timeout ct))
|
|
(else (scm-error 'wrong-type-arg "thread-sleep!"
|
|
"Wrong type argument: ~S"
|
|
(list timeout)
|
|
'()))))
|
|
(secs (inexact->exact (truncate t)))
|
|
(usecs (inexact->exact (truncate (* (- t secs) 1000000)))))
|
|
(when (> secs 0) (sleep secs))
|
|
(when (> usecs 0) (usleep usecs))
|
|
*unspecified*))
|
|
|
|
;; Whereas SRFI-34 leaves the continuation of a call to an exception
|
|
;; handler unspecified, SRFI-18 has this to say:
|
|
;;
|
|
;; When one of the primitives defined in this SRFI raises an exception
|
|
;; defined in this SRFI, the exception handler is called with the same
|
|
;; continuation as the primitive (i.e. it is a tail call to the
|
|
;; exception handler).
|
|
;;
|
|
;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run
|
|
;; handlers with the continuation of the primitive call, for those
|
|
;; primitives that throw exceptions.
|
|
|
|
(define (with-exception-handlers-here thunk)
|
|
(let ((tag (make-prompt-tag)))
|
|
(call-with-prompt tag
|
|
(lambda ()
|
|
(with-exception-handler (lambda (exn) (abort-to-prompt tag exn))
|
|
thunk))
|
|
(lambda (k exn)
|
|
((current-exception-handler) exn)))))
|
|
|
|
;; A unique value.
|
|
(define %cancel-sentinel (list 'cancelled))
|
|
(define (thread-terminate! thread)
|
|
(threads:cancel-thread thread %cancel-sentinel)
|
|
*unspecified*)
|
|
|
|
;; A unique value.
|
|
(define %timeout-sentinel (list 1))
|
|
(define* (thread-join! thread #:optional (timeout %timeout-sentinel)
|
|
(timeoutval %timeout-sentinel))
|
|
(with-exception-handlers-here
|
|
(lambda ()
|
|
(let ((v (if (eq? timeout %timeout-sentinel)
|
|
(threads:join-thread thread)
|
|
(threads:join-thread thread timeout %timeout-sentinel))))
|
|
(cond
|
|
((eq? v %timeout-sentinel)
|
|
(if (eq? timeoutval %timeout-sentinel)
|
|
(srfi-34:raise (condition (&join-timeout-exception)))
|
|
timeoutval))
|
|
((eq? v %cancel-sentinel)
|
|
(srfi-34:raise (condition (&terminated-thread-exception))))
|
|
((thread->exception thread) => srfi-34:raise)
|
|
(else v))))))
|
|
|
|
;; MUTEXES
|
|
;; These functions are all pass-thrus to the existing Guile implementations.
|
|
|
|
(define* (make-mutex #:optional name)
|
|
(let ((m (threads:make-mutex 'unchecked-unlock
|
|
'allow-external-unlock
|
|
'recursive)))
|
|
(when name (hashq-set! object-names m name))
|
|
m))
|
|
|
|
(define (mutex-name mutex)
|
|
(hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name")))
|
|
|
|
(define (mutex-specific mutex)
|
|
(hashq-ref object-specifics
|
|
(check-arg-type threads:mutex? mutex "mutex-specific")))
|
|
|
|
(define (mutex-specific-set! mutex obj)
|
|
(hashq-set! object-specifics
|
|
(check-arg-type threads:mutex? mutex "mutex-specific-set!")
|
|
obj)
|
|
*unspecified*)
|
|
|
|
(define (mutex-state mutex)
|
|
(let ((owner (threads:mutex-owner mutex)))
|
|
(if owner
|
|
(if (threads:thread-exited? owner) 'abandoned owner)
|
|
(if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned))))
|
|
|
|
(define (mutex-lock! mutex . args)
|
|
(with-exception-handlers-here
|
|
(lambda ()
|
|
(catch 'abandoned-mutex-error
|
|
(lambda () (apply threads:lock-mutex mutex args))
|
|
(lambda (key . args)
|
|
(srfi-34:raise
|
|
(condition (&abandoned-mutex-exception))))))))
|
|
|
|
(define (mutex-unlock! mutex . args)
|
|
(apply threads:unlock-mutex mutex args))
|
|
|
|
;; CONDITION VARIABLES
|
|
;; These functions are all pass-thrus to the existing Guile implementations.
|
|
|
|
(define* (make-condition-variable #:optional name)
|
|
(let ((m (threads:make-condition-variable)))
|
|
(when name (hashq-set! object-names m name))
|
|
m))
|
|
|
|
(define (condition-variable-name condition-variable)
|
|
(hashq-ref object-names (check-arg-type threads:condition-variable?
|
|
condition-variable
|
|
"condition-variable-name")))
|
|
|
|
(define (condition-variable-specific condition-variable)
|
|
(hashq-ref object-specifics (check-arg-type threads:condition-variable?
|
|
condition-variable
|
|
"condition-variable-specific")))
|
|
|
|
(define (condition-variable-specific-set! condition-variable obj)
|
|
(hashq-set! object-specifics
|
|
(check-arg-type threads:condition-variable?
|
|
condition-variable
|
|
"condition-variable-specific-set!")
|
|
obj)
|
|
*unspecified*)
|
|
|
|
(define (condition-variable-signal! cond)
|
|
(threads:signal-condition-variable cond)
|
|
*unspecified*)
|
|
|
|
(define (condition-variable-broadcast! cond)
|
|
(threads:broadcast-condition-variable cond)
|
|
*unspecified*)
|
|
|
|
;; TIME
|
|
|
|
(define current-time gettimeofday)
|
|
(define (time? obj)
|
|
(and (pair? obj)
|
|
(let ((co (car obj))) (and (integer? co) (>= co 0)))
|
|
(let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
|
|
|
|
(define (time->seconds time)
|
|
(and (check-arg-type time? time "time->seconds")
|
|
(+ (car time) (/ (cdr time) 1000000))))
|
|
|
|
(define (seconds->time x)
|
|
(and (check-arg-type number? x "seconds->time")
|
|
(let ((fx (truncate x)))
|
|
(cons (inexact->exact fx)
|
|
(inexact->exact (truncate (* (- x fx) 1000000)))))))
|
|
|
|
;; srfi-18.scm ends here
|