diff options
author | Andy Wingo <wingo@pobox.com> | 2016-11-04 22:35:19 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-11-04 22:35:19 +0100 |
commit | 3ce76c38cb3d041970c483635429743318938aa5 (patch) | |
tree | 238f1c7b28bc97fce1c5294fd79a55c06b7074bf | |
parent | bb4e955f0c26c8dc8a051028a7a145cb418bd155 (diff) | |
download | guile-3ce76c38cb3d041970c483635429743318938aa5.tar.gz |
SRFI-18 threads disjoint from guile threads
* doc/ref/srfi-modules.texi (SRFI-18 Threads): Update.
* module/srfi/srfi-18.scm (<mutex>): Add owner field.
(<thread>): New data type.
(make-thread): Adapt for boxed threads.
(thread-start!, thread-terminate!): Likewise.
(mutex-state): Adapt for boxed threads.
(mutex-lock!, mutex-unlock!): Update owner field.
-rw-r--r-- | doc/ref/srfi-modules.texi | 3 | ||||
-rw-r--r-- | module/srfi/srfi-18.scm | 142 |
2 files changed, 78 insertions, 67 deletions
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c307fcf9d..1cada278a 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2085,6 +2085,9 @@ execution until @code{thread-start!} is called on it. Second, SRFI-18 threads are constructed with a top-level exception handler that captures any exceptions that are thrown on thread exit. +SRFI-18 threads are disjoint from Guile's primitive threads. +@xref{Threads}, for more on Guile's primitive facility. + @defun current-thread Returns the thread that called this function. This is the same procedure as the same-named built-in procedure @code{current-thread} diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 69c03380b..d3a6a0909 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -80,10 +80,10 @@ terminated-thread-exception? uncaught-exception? uncaught-exception-reason) - #:re-export ((threads:current-thread . current-thread) - (threads:thread? . thread?) - (srfi-34:raise . raise)) + #:re-export ((srfi-34:raise . raise)) #:replace (current-time + current-thread + thread? make-thread make-mutex mutex? @@ -112,11 +112,12 @@ (reason uncaught-exception-reason)) (define-record-type <mutex> - (%make-mutex prim name specific) + (%make-mutex prim name specific owner) mutex? (prim mutex-prim) (name mutex-name) - (specific mutex-specific mutex-specific-set!)) + (specific mutex-specific mutex-specific-set!) + (owner mutex-owner set-mutex-owner!)) (define-record-type <condition-variable> (%make-condition-variable prim name specific) @@ -125,10 +126,16 @@ (name condition-variable-name) (specific condition-variable-specific condition-variable-specific-set!)) -(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)) -(define thread->exception (make-object-property)) +(define-record-type <thread> + (%make-thread prim name specific start-conds exception) + thread? + (prim thread-prim set-thread-prim!) + (name thread-name) + (specific thread-specific thread-specific-set!) + (start-conds thread-start-conds set-thread-start-conds!) + (exception thread-exception set-thread-exception!)) + +(define current-thread (make-parameter (%make-thread #f #f #f #f #f))) (define thread-mutexes (make-parameter #f)) ;; EXCEPTIONS @@ -177,50 +184,37 @@ mutexes)))))) (define* (make-thread thunk #:optional name) - (let ((sm (make-mutex 'start-mutex)) - (sc (make-condition-variable 'start-condition-variable))) + (let* ((sm (make-mutex 'start-mutex)) + (sc (make-condition-variable 'start-condition-variable)) + (thread (%make-thread #f name #f (cons sm sc) #f))) (mutex-lock! sm) - (let ((t (threads:call-with-new-thread - (lambda () - (catch #t - (lambda () - (with-thread-mutex-cleanup + (let ((prim (threads:call-with-new-thread + (lambda () + (catch #t (lambda () - (mutex-lock! sm) - (condition-variable-signal! sc) - (mutex-unlock! sm sc) - (thunk)))) - (lambda (key . args) - (set! (thread->exception (threads:current-thread)) - (condition (&uncaught-exception - (reason - (match (cons key args) - (('srfi-34 obj) obj) - (obj obj)))))))))))) - (when name (hashq-set! object-names t name)) + (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)))))))))))) + (set-thread-prim! thread prim) (mutex-unlock! sm sc) - (hashq-set! thread-start-conds t (cons sm sc)) - t))) - -(define (thread-name thread) - (hashq-ref object-names - (check-arg-type threads:thread? thread "thread-name"))) - -(define (thread-specific thread) - (hashq-ref object-specifics - (check-arg-type threads:thread? thread "thread-specific"))) - -(define (thread-specific-set! thread obj) - (hashq-set! object-specifics - (check-arg-type threads:thread? thread "thread-specific-set!") - obj) - *unspecified*) + thread))) (define (thread-start! thread) - (match (hashq-ref thread-start-conds - (check-arg-type threads:thread? thread "thread-start!")) + (match (thread-start-conds thread) ((smutex . scond) - (hashq-remove! thread-start-conds thread) + (set-thread-start-conds! thread #f) (mutex-lock! smutex) (condition-variable-signal! scond) (mutex-unlock! smutex)) @@ -267,27 +261,28 @@ ;; A unique value. (define %cancel-sentinel (list 'cancelled)) (define (thread-terminate! thread) - (threads:cancel-thread thread %cancel-sentinel) + (threads:cancel-thread (thread-prim thread) %cancel-sentinel) *unspecified*) ;; A unique value. (define %timeout-sentinel (list 1)) (define* (thread-join! thread #:optional (timeout %timeout-sentinel) (timeoutval %timeout-sentinel)) - (with-exception-handlers-here - (lambda () - (let ((v (if (eq? timeout %timeout-sentinel) - (threads:join-thread thread) - (threads:join-thread thread 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))) + (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))))))) ;; MUTEXES ;; These functions are all pass-thrus to the existing Guile implementations. @@ -297,38 +292,51 @@ 'allow-external-unlock 'recursive) name + #f #f)) (define (mutex-state mutex) (let* ((prim (mutex-prim mutex)) - (owner (threads:mutex-owner prim))) + (owner (mutex-owner mutex))) (if owner - (if (threads:thread-exited? owner) 'abandoned owner) + (if (and=> (thread-prim owner) threads:thread-exited?) + 'abandoned + owner) (if (> (threads:mutex-level prim) 0) 'not-owned 'not-abandoned)))) (define (abandon-mutex! mutex) #t) -(define (mutex-lock! mutex . args) +(define* (mutex-lock! mutex #:optional timeout (thread (current-thread))) (let ((mutexes (thread-mutexes))) (when mutexes (hashq-set! mutexes mutex #t))) (with-exception-handlers-here (lambda () (catch 'abandoned-mutex-error - (lambda () (apply threads:lock-mutex (mutex-prim mutex) args)) + (lambda () + (cond + ((threads:lock-mutex (mutex-prim mutex) timeout) + (set-mutex-owner! mutex thread) + #t) + (else #f))) (lambda (key . args) + (set-mutex-owner! mutex thread) (srfi-34:raise (condition (&abandoned-mutex-exception)))))))) (define mutex-unlock! (case-lambda ((mutex) - (threads:unlock-mutex (mutex-prim mutex))) + (set-mutex-owner! mutex #f) + (threads:unlock-mutex (mutex-prim mutex)) + #t) ((mutex cond) + (set-mutex-owner! mutex #f) (threads:unlock-mutex (mutex-prim mutex) (condition-variable-prim cond))) ((mutex cond timeout) + (set-mutex-owner! mutex #f) (threads:unlock-mutex (mutex-prim mutex) (condition-variable-prim cond) timeout)))) |