summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-18.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-10-31 21:07:03 +0100
committerAndy Wingo <wingo@pobox.com>2016-10-31 21:20:47 +0100
commit8e305ee0459cf22e4ccc889e38c0fd6f1782648d (patch)
tree8f0dd0ca658845cbe77c7e52d4ceaf682c2d76ed /module/srfi/srfi-18.scm
parent789a4d8d87ecdef9e785e04de4b57e01e762b36e (diff)
downloadguile-8e305ee0459cf22e4ccc889e38c0fd6f1782648d.tar.gz
Rationalize exception handling in srfi-18
* module/srfi/srfi-18.scm (make-thread): Inline some helpers, and use just one catch block. (thread->exception): Move up definition. (exception-handler-for-foreign-threads): Use this as the default handler, not the one that squirrels away exceptions in thread->exception. (thread-terminate!): Don't instate an exception handler for the thread cleanup proc.
Diffstat (limited to 'module/srfi/srfi-18.scm')
-rw-r--r--module/srfi/srfi-18.scm82
1 files changed, 38 insertions, 44 deletions
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 46c069ee8..6ff88abcb 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -113,26 +113,20 @@
(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))
-
-;; EXCEPTIONS
-
-(define (initial-handler obj)
- (set! (thread->exception (threads:current-thread))
- (condition (&uncaught-exception (reason obj)))))
-
(define thread->exception (make-object-property))
-(define (srfi-18-exception-handler key . args)
-
- ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
- ;; if one is caught at this level, it has already been taken care of by
- ;; `initial-handler'.
+;; EXCEPTIONS
- (unless (eq? key 'srfi-34)
- (set! (thread->exception (threads:current-thread))
- (condition (&uncaught-exception (reason (cons key args)))))))
+;; 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 initial-handler))
+(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")
@@ -152,32 +146,33 @@
;; Once started, install a top-level exception handler that rethrows any
;; exceptions wrapped in an uncaught-exception wrapper.
-(define make-thread
- (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
- (lambda ()
- (threads:lock-mutex lmutex)
- (threads:signal-condition-variable lcond)
- (threads:lock-mutex smutex)
- (threads:unlock-mutex lmutex)
- (threads:wait-condition-variable scond smutex)
- (threads:unlock-mutex smutex)
- (with-exception-handler initial-handler
- thunk)))))
- (lambda* (thunk #:optional name)
- (let ((lm (make-mutex 'launch-mutex))
- (lc (make-condition-variable 'launch-condition-variable))
- (sm (make-mutex 'start-mutex))
- (sc (make-condition-variable 'start-condition-variable)))
-
- (threads:lock-mutex lm)
- (let ((t (threads:call-with-new-thread
- (make-cond-wrapper thunk lc lm sc sm)
- srfi-18-exception-handler)))
- (hashq-set! thread-start-conds t (cons sm sc))
- (when name (hashq-set! object-names t name))
- (threads:wait-condition-variable lc lm)
- (threads:unlock-mutex lm)
- t)))))
+(define* (make-thread thunk #:optional name)
+ (let ((lm (make-mutex 'launch-mutex))
+ (lc (make-condition-variable 'launch-condition-variable))
+ (sm (make-mutex 'start-mutex))
+ (sc (make-condition-variable 'start-condition-variable)))
+ (threads:lock-mutex lm)
+ (let ((t (threads:call-with-new-thread
+ (lambda ()
+ (threads:lock-mutex lm)
+ (threads:signal-condition-variable lc)
+ (threads:lock-mutex sm)
+ (threads:unlock-mutex lm)
+ (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))))))))))
+ (hashq-set! thread-start-conds t (cons sm sc))
+ (when name (hashq-set! object-names t name))
+ (threads:wait-condition-variable lc lm)
+ (threads:unlock-mutex lm)
+ t)))
(define (thread-name thread)
(hashq-ref object-names
@@ -253,8 +248,7 @@
(condition (&terminated-thread-exception))))))
(if (thunk? current-handler)
(lambda ()
- (with-exception-handler initial-handler
- current-handler)
+ (current-handler)
(handler))
handler)))
(threads:cancel-thread thread)