diff options
author | Andy Wingo <wingo@pobox.com> | 2019-11-14 16:33:10 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-11-14 16:33:10 +0100 |
commit | 95efe14e449be5b80c8309ae91682696d6d79c9f (patch) | |
tree | d4ac36269c557ffad603505d2b6fe31a640856f0 /module/srfi | |
parent | 44ee8c5559ed2f30df464ba1bffdae24994291b3 (diff) | |
download | guile-95efe14e449be5b80c8309ae91682696d6d79c9f.tar.gz |
SRFI-18 uses core exceptions
* module/ice-9/boot-9.scm (exception-kind, exception-args): Export.
* module/ice-9/exceptions.scm (exception-kind, exception-args):
Re-export.
* module/srfi/srfi-18.scm: Rewrite exception support in terms of core
exceptions, not SRFI-34/35.
* test-suite/tests/srfi-18.test: Since Guile doesn't expose the current
exception handler as such, SRFI-18 captures it using delimited
continuations. This means that we can't compare the result
of (current-exception-handler) with the installed handler using eq?,
even though the procedures are indeed equivalent. So, instead test
handler behavior.
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-18.scm | 146 |
1 files changed, 60 insertions, 86 deletions
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 7177e0690..6decb8ca4 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -31,13 +31,10 @@ ;;; Code: (define-module (srfi srfi-18) + #:use-module (ice-9 exceptions) #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (ice-9 match) #:use-module (srfi srfi-9) - #: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 @@ -74,13 +71,13 @@ seconds->time current-exception-handler - with-exception-handler join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason) - #:re-export ((srfi-34:raise . raise)) + #:re-export ((raise-continuable . raise) + with-exception-handler) #:replace (current-time current-thread thread? @@ -101,14 +98,14 @@ (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? +(define-exception-type &abandoned-mutex-exception &external-error + make-abandoned-mutex-exception abandoned-mutex-exception?) +(define-exception-type &join-timeout-exception &external-error + make-join-timeout-exception join-timeout-exception?) +(define-exception-type &terminated-thread-exception &external-error + make-terminated-thread-exception terminated-thread-exception?) +(define-exception-type &uncaught-exception &programming-error + make-uncaught-exception uncaught-exception? (reason uncaught-exception-reason)) (define-record-type <mutex> @@ -159,20 +156,17 @@ object (absolute point in time), or #f." (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))))) +(define (current-exception-handler) + (let ((tag (make-prompt-tag))) + (call-with-prompt + tag + (lambda () + (with-exception-handler + (lambda (exn) + (raise-exception (abort-to-prompt tag) #:continuable? #t)) + (lambda () + (raise-exception #f #:continuable? #t)))) + (lambda (k) k)))) ;; THREADS @@ -201,23 +195,19 @@ object (absolute point in time), or #f." (mutex-lock! sm) (let ((prim (threads:call-with-new-thread (lambda () - (catch #t - (lambda () - (parameterize ((current-thread thread)) - (with-thread-mutex-cleanup - (lambda () - (mutex-lock! sm) - (condition-variable-signal! sc) - (mutex-unlock! sm sc) - (thunk))))) - (lambda (key . args) - (set-thread-exception! - thread - (condition (&uncaught-exception - (reason - (match (cons key args) - (('srfi-34 obj) obj) - (obj obj)))))))))))) + (with-exception-handler + (lambda (exn) + (set-thread-exception! thread + (make-uncaught-exception exn))) + (lambda () + (parameterize ((current-thread thread)) + (with-thread-mutex-cleanup + (lambda () + (mutex-lock! sm) + (condition-variable-signal! sc) + (mutex-unlock! sm sc) + (thunk))))) + #:unwind? #t))))) (set-thread-prim! thread prim) (mutex-unlock! sm sc) thread))) @@ -248,26 +238,14 @@ object (absolute point in time), or #f." (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: +;; 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))))) +;; Therefore we use raise-continuable as appropriate. ;; A unique value. (define %cancel-sentinel (list 'cancelled)) @@ -279,21 +257,19 @@ object (absolute point in time), or #f." (define %timeout-sentinel (list 1)) (define* (thread-join! thread #:optional (timeout %timeout-sentinel) (timeoutval %timeout-sentinel)) - (let ((t (thread-prim thread))) - (with-exception-handlers-here - (lambda () - (let* ((v (if (eq? timeout %timeout-sentinel) - (threads:join-thread t) - (threads:join-thread t 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))))))) + (let* ((t (thread-prim thread)) + (v (if (eq? timeout %timeout-sentinel) + (threads:join-thread t) + (threads:join-thread t timeout %timeout-sentinel)))) + (cond + ((eq? v %timeout-sentinel) + (if (eq? timeoutval %timeout-sentinel) + (raise-continuable (make-join-timeout-exception)) + timeoutval)) + ((eq? v %cancel-sentinel) + (raise-continuable (make-terminated-thread-exception))) + ((thread-exception thread) => raise-continuable) + (else v)))) ;; MUTEXES @@ -315,18 +291,16 @@ object (absolute point in time), or #f." (let ((mutexes (thread-mutexes))) (when mutexes (hashq-set! mutexes mutex #t))) - (with-exception-handlers-here - (lambda () - (cond - ((threads:lock-mutex (mutex-prim mutex) - (timeout->absolute-time timeout)) - (set-mutex-owner! mutex thread) - (when (mutex-abandoned? mutex) - (set-mutex-abandoned?! mutex #f) - (srfi-34:raise - (condition (&abandoned-mutex-exception)))) - #t) - (else #f))))) + (cond + ((threads:lock-mutex (mutex-prim mutex) + (timeout->absolute-time timeout)) + (set-mutex-owner! mutex thread) + (cond + ((mutex-abandoned? mutex) + (set-mutex-abandoned?! mutex #f) + (raise-continuable (make-abandoned-mutex-exception))) + (else #t))) + (else #f))) (define %unlock-sentinel (list 'unlock)) (define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel) |