diff options
author | Andy Wingo <wingo@pobox.com> | 2016-11-04 20:15:01 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-11-04 20:17:58 +0100 |
commit | 255963186902a62455942124e27c3a7e8c2fc476 (patch) | |
tree | 5e7868845c8b7f27628d4079bcd49762067b1e74 | |
parent | 0f5a59b215fdeff23d2632de1dfe7a22bfcb9d82 (diff) | |
download | guile-255963186902a62455942124e27c3a7e8c2fc476.tar.gz |
SRFI-18 mutexes disjoint from Guile mutexes
* module/srfi/srfi-18.scm (<mutex>): Define as a wrapper type around
Guile mutexes.
(thread-mutexes): New variable.
(with-thread-mutex-cleanup): New facility to abandon mutexes on
SRFI-18 thread exit. Not yet used.
(make-thread): Use SRFI-18 interfaces.
(make-mutex): Reimplement for our boxed mutexes.
(mutex-state): Adapt.
(mutex-lock!): Adapt.
(mutex-unlock!): Adapt.
* test-suite/tests/srfi-18.test: Don't assume that SRFI-18 mutexes are
the same as Guile mutexes.
-rw-r--r-- | module/srfi/srfi-18.scm | 103 | ||||
-rw-r--r-- | test-suite/tests/srfi-18.test | 9 |
2 files changed, 68 insertions, 44 deletions
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 36b19e7e3..b9739b25d 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -33,6 +33,7 @@ (define-module (srfi srfi-18) #: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 @@ -50,6 +51,7 @@ ;; Mutexes make-mutex + mutex mutex-name mutex-specific mutex-specific-set! @@ -82,11 +84,11 @@ #:re-export ((threads:condition-variable? . condition-variable?) (threads:current-thread . current-thread) (threads:thread? . thread?) - (threads:mutex? . mutex?) (srfi-34:raise . raise)) #:replace (current-time make-thread make-mutex + mutex? make-condition-variable)) (unless (provided? 'threads) @@ -110,10 +112,18 @@ uncaught-exception? (reason uncaught-exception-reason)) +(define-record-type <mutex> + (%make-mutex prim name specific) + mutex? + (prim mutex-prim) + (name mutex-name) + (specific mutex-specific mutex-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 thread-mutexes (make-parameter #f)) ;; EXCEPTIONS @@ -146,28 +156,45 @@ ;; Once started, install a top-level exception handler that rethrows any ;; exceptions wrapped in an uncaught-exception wrapper. +(define (with-thread-mutex-cleanup thunk) + (let ((mutexes (make-weak-key-hash-table))) + (dynamic-wind + values + (lambda () + (parameterize ((thread-mutexes mutexes)) + (thunk))) + (lambda () + (let ((thread (current-thread))) + (hash-for-each (lambda (mutex _) + (when (eq? (mutex-state mutex) thread) + (abandon-mutex! mutex))) + mutexes)))))) + (define* (make-thread thunk #:optional name) (let ((sm (make-mutex 'start-mutex)) (sc (make-condition-variable 'start-condition-variable))) - (threads:lock-mutex sm) + (mutex-lock! sm) (let ((t (threads:call-with-new-thread (lambda () - (threads:lock-mutex sm) - (threads:signal-condition-variable sc) - (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)))))))))) + (catch #t + (lambda () + (with-thread-mutex-cleanup + (lambda () + (mutex-lock! sm) + (threads:signal-condition-variable 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)) - (threads:wait-condition-variable sc sm) + (threads:wait-condition-variable sc (mutex-prim sm)) (hashq-set! thread-start-conds t (cons sm sc)) - (threads:unlock-mutex sm) + (mutex-unlock! sm) t))) (define (thread-name thread) @@ -189,9 +216,9 @@ (check-arg-type threads:thread? thread "thread-start!")) ((smutex . scond) (hashq-remove! thread-start-conds thread) - (threads:lock-mutex smutex) + (mutex-lock! smutex) (threads:signal-condition-variable scond) - (threads:unlock-mutex smutex)) + (mutex-unlock! smutex)) (#f #f)) thread) @@ -261,42 +288,36 @@ ;; These functions are all pass-thrus to the existing Guile implementations. (define* (make-mutex #:optional name) - (let ((m (threads:make-mutex 'unchecked-unlock - 'allow-external-unlock - 'recursive))) - (when name (hashq-set! object-names m name)) - m)) - -(define (mutex-name mutex) - (hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name"))) - -(define (mutex-specific mutex) - (hashq-ref object-specifics - (check-arg-type threads:mutex? mutex "mutex-specific"))) - -(define (mutex-specific-set! mutex obj) - (hashq-set! object-specifics - (check-arg-type threads:mutex? mutex "mutex-specific-set!") - obj) - *unspecified*) + (%make-mutex (threads:make-mutex 'unchecked-unlock + 'allow-external-unlock + 'recursive) + name + #f)) (define (mutex-state mutex) - (let ((owner (threads:mutex-owner mutex))) + (let* ((prim (mutex-prim mutex)) + (owner (threads:mutex-owner prim))) (if owner - (if (threads:thread-exited? owner) 'abandoned owner) - (if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned)))) + (if (threads:thread-exited? owner) 'abandoned owner) + (if (> (threads:mutex-level prim) 0) 'not-owned 'not-abandoned)))) + +(define (abandon-mutex! mutex) + #t) (define (mutex-lock! mutex . args) + (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 args)) + (lambda () (apply threads:lock-mutex (mutex-prim mutex) args)) (lambda (key . args) (srfi-34:raise (condition (&abandoned-mutex-exception)))))))) (define (mutex-unlock! mutex . args) - (apply threads:unlock-mutex mutex args)) + (apply threads:unlock-mutex (mutex-prim mutex) args)) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index a0474a35f..ddd72dbab 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -377,7 +377,8 @@ (dec-sem! (lambda () (mutex-lock! m1) (while (eqv? sem 0) - (threads:wait-condition-variable c1 m1)) + (mutex-unlock! m1 c1) + (mutex-lock! m1)) (set! sem (- sem 1)) (mutex-unlock! m1))) (t1 (make-thread (lambda () @@ -451,13 +452,15 @@ h2 (lambda () (mutex-lock! m) (condition-variable-signal! c) - (threads:wait-condition-variable c m) + (mutex-unlock! m c) + (mutex-lock! m) (and (eq? (current-exception-handler) h2) (mutex-unlock! m))))) 'current-exception-handler-4))) (mutex-lock! m) (thread-start! t) - (threads:wait-condition-variable c m) + (mutex-unlock! m c) + (mutex-lock! m) (and (eq? (current-exception-handler) h1) (condition-variable-signal! c) (mutex-unlock! m) |