summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2016-11-04 20:15:01 +0100
committerAndy Wingo <wingo@pobox.com>2016-11-04 20:17:58 +0100
commit255963186902a62455942124e27c3a7e8c2fc476 (patch)
tree5e7868845c8b7f27628d4079bcd49762067b1e74
parent0f5a59b215fdeff23d2632de1dfe7a22bfcb9d82 (diff)
downloadguile-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.scm103
-rw-r--r--test-suite/tests/srfi-18.test9
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)