From 95efe14e449be5b80c8309ae91682696d6d79c9f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Nov 2019 16:33:10 +0100 Subject: 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. --- module/ice-9/boot-9.scm | 4 +- module/ice-9/exceptions.scm | 3 + module/srfi/srfi-18.scm | 146 +++++++++++++++++------------------------- test-suite/tests/srfi-18.test | 39 ++++++----- 4 files changed, 88 insertions(+), 104 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ccfdc933c..4b2567455 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1538,7 +1538,9 @@ exception that is an instance of @var{rtd}." (else exn))))) - (define-values* (raise-exception + (define-values* (exception-kind + exception-args + raise-exception with-exception-handler catch with-throw-handler diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm index f9fe2fb31..25f68a387 100644 --- a/module/ice-9/exceptions.scm +++ b/module/ice-9/exceptions.scm @@ -32,6 +32,9 @@ exception-predicate exception-accessor + exception-kind + exception-args + &error &programming-error &non-continuable 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 @@ -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) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index e5473391a..2026912cf 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -461,21 +461,24 @@ (pass-if "current handler returned at top level" (procedure? (current-exception-handler))) - (pass-if "specified handler set under with-exception-handler" - (let ((h (lambda (key . args) 'nothing))) - (with-exception-handler h (lambda () (eq? (current-exception-handler) - h))))) - - (pass-if "multiple levels of handler nesting" - (let ((h (lambda (key . args) 'nothing)) - (i (current-exception-handler))) - (and (with-exception-handler h (lambda () - (eq? (current-exception-handler) h))) - (eq? (current-exception-handler) i)))) + (pass-if-equal "specified handler set under with-exception-handler" + 'nothing + (let ((h (lambda (exn) 'nothing))) + (with-exception-handler + h + (lambda () ((current-exception-handler) #f))))) + + (pass-if-equal "multiple levels of handler nesting" + 42 + (with-exception-handler + (lambda (exn) (+ exn 20)) + (lambda () + (with-exception-handler + (lambda (exn) (raise (+ exn 12))) + (lambda () (raise 10)))))) (pass-if "exception handler installation is thread-safe" - (let* ((h1 (current-exception-handler)) - (h2 (lambda (key . args) 'nothing-2)) + (let* ((h2 (lambda (exn) 'nothing-2)) (m (make-mutex 'current-exception-handler-4)) (c (make-condition-variable 'current-exception-handler-4)) (t (make-thread (lambda () @@ -485,15 +488,14 @@ (condition-variable-signal! c) (mutex-unlock! m c) (mutex-lock! m) - (and (eq? (current-exception-handler) h2) + (and (eq? (raise #f) 'nothing-2) (mutex-unlock! m))))) 'current-exception-handler-4))) (mutex-lock! m) (thread-start! t) (mutex-unlock! m c) (mutex-lock! m) - (and (eq? (current-exception-handler) h1) - (condition-variable-signal! c) + (and (condition-variable-signal! c) (mutex-unlock! m) (thread-join! t))))) @@ -518,7 +520,10 @@ (with-exception-handler (lambda (obj) (and (uncaught-exception? obj) - (equal? (uncaught-exception-reason obj) '(foo)) + (equal? (exception-kind (uncaught-exception-reason obj)) + 'foo) + (equal? (exception-args (uncaught-exception-reason obj)) + '()) (set! success #t))) (lambda () (thread-join! t))) success))))) -- cgit v1.2.3