[Guile-commits] 11/17: Rationalize exception handling in srfi-18

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8e305ee0459cf22e4ccc889e38c0fd6f1782648d
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 31 21:07:03 2016 +0100

    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.
---
 module/srfi/srfi-18.scm |   82 ++++++++++++++++++++++-------------------------
 1 file changed, 38 insertions(+), 44 deletions(-)

diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 46c069e..6ff88ab 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)