mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

srfi-18: thread-terminate! without cleanup handlers

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-10-31 22:11:43 +01:00
parent a7114ced5f
commit b85f033526
1 changed files with 13 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

36
module/srfi/srfi-18.scm
View file

@ -232,38 +232,28 @@
(lambda (k exn) (lambda (k exn)
((current-exception-handler) exn))))) ((current-exception-handler) exn)))))
;; A pass-thru to cancel-thread that first installs a handler that throws ;; A unique value.
;; terminated-thread exception, as per SRFI-18, (define %cancel-sentinel (list 'cancelled))
(define (thread-terminate! thread) (define (thread-terminate! thread)
(let ((current-handler (threads:thread-cleanup thread))) (threads:cancel-thread thread %cancel-sentinel)
(threads:set-thread-cleanup! *unspecified*)
thread
(let ((handler (lambda ()
(set! (thread->exception (threads:current-thread))
(condition (&terminated-thread-exception))))))
(if (thunk? current-handler)
(lambda ()
(current-handler)
(handler))
handler)))
(threads:cancel-thread thread)
*unspecified*))
;; A unique value. ;; A unique value.
(define %sentinel (list 1)) (define %timeout-sentinel (list 1))
(define* (thread-join! thread #:optional (timeout %sentinel) (define* (thread-join! thread #:optional (timeout %timeout-sentinel)
(timeoutval %sentinel)) (timeoutval %timeout-sentinel))
(with-exception-handlers-here (with-exception-handlers-here
(lambda () (lambda ()
(let ((v (if (eq? timeout %sentinel) (let ((v (if (eq? timeout %timeout-sentinel)
(threads:join-thread thread) (threads:join-thread thread)
(threads:join-thread thread timeout %sentinel)))) (threads:join-thread thread timeout %timeout-sentinel))))
(cond (cond
((eq? v %sentinel) ((eq? v %timeout-sentinel)
(if (eq? timeoutval %sentinel) (if (eq? timeoutval %timeout-sentinel)
(srfi-34:raise (condition (&join-timeout-exception))) (srfi-34:raise (condition (&join-timeout-exception)))
timeoutval)) timeoutval))
((eq? v %cancel-sentinel)
(srfi-34:raise (condition (&terminated-thread-exception))))
((thread->exception thread) => srfi-34:raise) ((thread->exception thread) => srfi-34:raise)
(else v)))))) (else v))))))