From: "Julian Graham" <joolean@gmail.com>
To: "Neil Jerram" <neil@ossau.uklinux.net>
Cc: "Ludovic Courtès" <ludo@gnu.org>, guile-devel@gnu.org
Subject: Re: srfi-18 requirements
Date: Thu, 15 May 2008 01:05:34 -0400 [thread overview]
Message-ID: <2bc5f8210805142205o4bfd13f1x5f449a7ad6b64700@mail.gmail.com> (raw)
In-Reply-To: <87ve1gscpj.fsf@ossau.uklinux.net>
[-- Attachment #1: Type: text/plain, Size: 961 bytes --]
Hi Neil,
> I haven't covered these yet. Will try to soon, but could you resubmit
> anyway as a GIT commit patch, so that you end up being properly
> credited for the commit?
Yes -- find one attached. As an aside, I've been having some
difficulty with git, specifically when it comes to backing out commits
that I've created prematurely (e.g., without git-adding the
ChangeLogs). Do you guys have any recommendations for tools that add
a bit of sugar to the interface, or do I just have to buckle down and
learn the thing?
> Should m->level be set to 1 here?
Can I take it you're talking about the case in which a thread is
taking over an abandoned mutex that may have been locked more than
once, recursively, by the exited thread? If so, yes -- m->level
should definitely be set back to 1. Thanks for catching that!
> Regards, and thanks once again for your work on this area!
My pleasure! Thank you for your continued patience.
Regards,
Julian
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Scheme-SRFI-18-implementation-and-tests-file.patch --]
[-- Type: text/x-diff; name=0001-Scheme-SRFI-18-implementation-and-tests-file.patch, Size: 30433 bytes --]
From 75e5e5c7aad78876fb9e4a2c1523491f58985917 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian@smokebottle.(none)>
Date: Thu, 15 May 2008 00:50:50 -0400
Subject: [PATCH] Scheme SRFI-18 implementation and tests file
---
srfi/ChangeLog | 4 +
srfi/srfi-18.scm | 379 ++++++++++++++++++++++++++++++++
test-suite/ChangeLog | 4 +
test-suite/tests/srfi-18.test | 477 +++++++++++++++++++++++++++++++++++++++++
4 files changed, 864 insertions(+), 0 deletions(-)
create mode 100644 srfi/srfi-18.scm
create mode 100644 test-suite/tests/srfi-18.test
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 1f6c599..fe88665 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15 Julian Graham <joolean@gmail.com>
+
+ * srfi-18.scm: New file.
+
2008-04-28 Ludovic Courtès <ludo@gnu.org>
* srfi-1.c (scm_srfi1_partition): Properly type-check LIST.
diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm
new file mode 100644
index 0000000..0593f4e
--- /dev/null
+++ b/srfi/srfi-18.scm
@@ -0,0 +1,379 @@
+;;; srfi-18.scm --- Multithreading support
+
+;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Julian Graham <julian.graham@aya.yale.edu>
+;;; Date: 2008-04-11
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-18 (Multithreading support).
+;;
+;; All procedures defined in SRFI-18, which are not already defined in
+;; the Guile core library, are exported.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-18)
+ :use-module (srfi srfi-34)
+ :export (
+
+;;; Threads
+ ;; current-thread <= in the core
+ ;; thread? <= in the core
+ make-thread
+ thread-name
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-yield!
+ thread-sleep!
+ thread-terminate!
+ thread-join!
+
+;;; Mutexes
+ ;; mutex? <= in the core
+ make-mutex
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-lock!
+ mutex-unlock!
+
+;;; Condition variables
+ ;; condition-variable? <= in the core
+ make-condition-variable
+ condition-variable-name
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable-signal!
+ condition-variable-broadcast!
+ condition-variable-wait!
+
+;;; Time
+ current-time
+ time?
+ time->seconds
+ seconds->time
+
+ current-exception-handler
+ with-exception-handler
+ raise
+ join-timeout-exception?
+ abandoned-mutex-exception?
+ terminated-thread-exception?
+ uncaught-exception?
+ uncaught-exception-reason
+ )
+ :re-export (thread? mutex? condition-variable?)
+ :replace (current-time
+ make-thread
+ make-mutex
+ make-condition-variable
+ raise))
+
+(cond-expand-provide (current-module) '(srfi-18))
+
+(define (check-arg-type pred arg caller)
+ (if (pred arg)
+ arg
+ (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S" (list arg) '())))
+
+(define abandoned-mutex-exception (list 'abandoned-mutex-exception))
+(define join-timeout-exception (list 'join-timeout-exception))
+(define terminated-thread-exception (list 'terminated-thread-exception))
+(define uncaught-exception (list 'uncaught-exception))
+
+(define mutex-owners (make-weak-key-hash-table))
+(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-handlers (make-weak-key-hash-table))
+
+;; EXCEPTIONS
+
+(define raise (@ (srfi srfi-34) raise))
+(define (initial-handler obj)
+ (srfi-18-exception-preserver (cons uncaught-exception obj)))
+
+(define thread->exception (make-object-property))
+
+(define (srfi-18-exception-preserver obj)
+ (if (or (terminated-thread-exception? obj)
+ (uncaught-exception? obj))
+ (set! (thread->exception (current-thread)) obj)))
+
+(define (srfi-18-exception-handler key . args)
+
+ ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so
+ ;; if one is caught at this level, it has already been taken care of by
+ ;; `initial-handler'.
+
+ (and (not (eq? key 'srfi-34))
+ (srfi-18-exception-preserver (if (null? args)
+ (cons uncaught-exception key)
+ (cons* uncaught-exception key args)))))
+
+(define (current-handler-stack)
+ (let ((ct (current-thread)))
+ (or (hashq-ref thread-exception-handlers ct)
+ (hashq-set! thread-exception-handlers ct (list initial-handler)))))
+
+(define (with-exception-handler handler thunk)
+ (let ((ct (current-thread))
+ (hl (current-handler-stack)))
+ (check-arg-type procedure? handler "with-exception-handler")
+ (check-arg-type thunk? thunk "with-exception-handler")
+ (hashq-set! thread-exception-handlers ct (cons handler hl))
+ (apply (@ (srfi srfi-34) with-exception-handler)
+ (list (lambda (obj)
+ (hashq-set! thread-exception-handlers ct hl)
+ (handler obj))
+ (lambda ()
+ (let ((r (thunk)))
+ (hashq-set! thread-exception-handlers ct hl) r))))))
+
+(define (current-exception-handler)
+ (car (current-handler-stack)))
+
+(define (join-timeout-exception? obj) (eq? obj join-timeout-exception))
+(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception))
+(define (uncaught-exception? obj)
+ (and (pair? obj) (eq? (car obj) uncaught-exception)))
+(define (uncaught-exception-reason exc)
+ (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason")))
+(define (terminated-thread-exception? obj)
+ (eq? obj terminated-thread-exception))
+
+;; THREADS
+
+;; Create a new thread and prevent it from starting using a condition variable.
+;; Once started, install a top-level exception handler that rethrows any
+;; exceptions wrapped in an uncaught-exception wrapper.
+
+(define make-thread
+ (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex)
+ (lambda ()
+ (lock-mutex lmutex)
+ (signal-condition-variable lcond)
+ (lock-mutex smutex)
+ (unlock-mutex lmutex)
+ (wait-condition-variable scond smutex)
+ (unlock-mutex smutex)
+ (with-exception-handler initial-handler
+ thunk)))))
+ (lambda (thunk . name)
+ (let ((n (and (pair? name) (car name)))
+
+ (lm (make-mutex 'launch-mutex))
+ (lc (make-condition-variable 'launch-condition-variable))
+ (sm (make-mutex 'start-mutex))
+ (sc (make-condition-variable 'start-condition-variable)))
+
+ (lock-mutex lm)
+ (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm)
+ srfi-18-exception-handler)))
+ (hashq-set! thread-start-conds t (cons sm sc))
+ (and n (hashq-set! object-names t n))
+ (wait-condition-variable lc lm)
+ (unlock-mutex lm)
+ t)))))
+
+(define (thread-name thread)
+ (hashq-ref object-names (check-arg-type thread? thread "thread-name")))
+
+(define (thread-specific thread)
+ (hashq-ref object-specifics
+ (check-arg-type thread? thread "thread-specific")))
+
+(define (thread-specific-set! thread obj)
+ (hashq-set! object-specifics
+ (check-arg-type thread? thread "thread-specific-set!")
+ obj)
+ *unspecified*)
+
+(define (thread-start! thread)
+ (let ((x (hashq-ref thread-start-conds
+ (check-arg-type thread? thread "thread-start!"))))
+ (and x (let ((smutex (car x))
+ (scond (cdr x)))
+ (hashq-remove! thread-start-conds thread)
+ (lock-mutex smutex)
+ (signal-condition-variable scond)
+ (unlock-mutex smutex)))
+ thread))
+
+(define (thread-yield!) (yield) *unspecified*)
+
+(define (thread-sleep! timeout)
+ (let* ((ct (time->seconds (current-time)))
+ (t (cond ((time? timeout) (- (time->seconds timeout) ct))
+ ((number? timeout) (- timeout ct))
+ (else (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S"
+ (list timeout)
+ '()))))
+ (secs (inexact->exact (truncate t)))
+ (usecs (inexact->exact (truncate (* (- t secs) 1000)))))
+ (and (> secs 0) (sleep secs))
+ (and (> usecs 0) (usleep usecs))
+ *unspecified*))
+
+;; A convenience function for installing exception handlers on SRFI-18
+;; primitives that resume the calling continuation after the handler is
+;; invoked -- this resolves a behavioral incompatibility with Guile's
+;; implementation of SRFI-34, which uses lazy-catch and rethrows handled
+;; exceptions. (SRFI-18, "Primitives and exceptions")
+
+(define (wrap thunk)
+ (lambda (continuation)
+ (with-exception-handler (lambda (obj)
+ (apply (current-exception-handler) (list obj))
+ (apply continuation (list)))
+ thunk)))
+
+;; A pass-thru to cancel-thread that first installs a handler that throws
+;; terminated-thread exception, as per SRFI-18,
+
+(define (thread-terminate! thread)
+ (define (thread-terminate-inner!)
+ (let ((current-handler (thread-cleanup thread)))
+ (if (thunk? current-handler)
+ (set-thread-cleanup! thread
+ (lambda ()
+ (with-exception-handler initial-handler
+ current-handler)
+ (srfi-18-exception-preserver
+ terminated-thread-exception)))
+ (set-thread-cleanup! thread
+ (lambda () (srfi-18-exception-preserver
+ terminated-thread-exception))))
+ (cancel-thread thread)
+ *unspecified*))
+ (thread-terminate-inner!))
+
+(define (thread-join! thread . args)
+ (define thread-join-inner!
+ (wrap (lambda ()
+ (let ((v (apply join-thread (cons thread args)))
+ (e (thread->exception thread)))
+ (if (and (= (length args) 1) (not v))
+ (raise join-timeout-exception))
+ (if e (raise e))
+ v))))
+ (call/cc thread-join-inner!))
+
+;; MUTEXES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-mutex
+ (lambda name
+ (let ((n (and (pair? name) (car name)))
+ (m ((@ (guile) make-mutex)
+ 'unchecked-unlock
+ 'allow-external-unlock
+ 'recursive)))
+ (and n (hashq-set! object-names m n)) m)))
+
+(define (mutex-name mutex)
+ (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name")))
+
+(define (mutex-specific mutex)
+ (hashq-ref object-specifics
+ (check-arg-type mutex? mutex "mutex-specific")))
+
+(define (mutex-specific-set! mutex obj)
+ (hashq-set! object-specifics
+ (check-arg-type mutex? mutex "mutex-specific-set!")
+ obj)
+ *unspecified*)
+
+(define (mutex-state mutex)
+ (let ((owner (mutex-owner mutex)))
+ (if owner
+ (if (thread-exited? owner) 'abandoned owner)
+ (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned))))
+
+(define (mutex-lock! mutex . args)
+ (define mutex-lock-inner!
+ (wrap (lambda ()
+ (catch 'abandoned-mutex-error
+ (lambda () (apply lock-mutex (cons mutex args)))
+ (lambda (key . args) (raise abandoned-mutex-exception))))))
+ (call/cc mutex-lock-inner!))
+
+(define (mutex-unlock! mutex . args)
+ (apply unlock-mutex (cons mutex args)))
+
+;; CONDITION VARIABLES
+;; These functions are all pass-thrus to the existing Guile implementations.
+
+(define make-condition-variable
+ (lambda name
+ (let ((n (and (pair? name) (car name)))
+ (m ((@ (guile) make-condition-variable))))
+ (and n (hashq-set! object-names m n)) m)))
+
+(define (condition-variable-name condition-variable)
+ (hashq-ref object-names (check-arg-type condition-variable?
+ condition-variable
+ "condition-variable-name")))
+
+(define (condition-variable-specific condition-variable)
+ (hashq-ref object-specifics (check-arg-type condition-variable?
+ condition-variable
+ "condition-variable-specific")))
+
+(define (condition-variable-specific-set! condition-variable obj)
+ (hashq-set! object-specifics
+ (check-arg-type condition-variable?
+ condition-variable
+ "condition-variable-specific-set!")
+ obj)
+ *unspecified*)
+
+(define (condition-variable-signal! cond)
+ (signal-condition-variable cond)
+ *unspecified*)
+
+(define (condition-variable-broadcast! cond)
+ (broadcast-condition-variable cond)
+ *unspecified*)
+
+;; TIME
+
+(define current-time gettimeofday)
+(define (time? obj)
+ (and (pair? obj)
+ (let ((co (car obj))) (and (integer? co) (>= co 0)))
+ (let ((co (cdr obj))) (and (integer? co) (>= co 0)))))
+
+(define (time->seconds time)
+ (and (check-arg-type time? time "time->seconds")
+ (+ (car time) (/ (cdr time) 1000000))))
+
+(define (seconds->time x)
+ (and (check-arg-type number? x "seconds->time")
+ (let ((fx (truncate x)))
+ (cons (inexact->exact fx)
+ (inexact->exact (truncate (* (- x fx) 1000000)))))))
+
+;; srfi-18.scm ends here
\ No newline at end of file
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index 1d73fbf..5f97142 100644
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,7 @@
+2008-05-15 Julian Graham <joolean@gmail.com>
+
+ * tests/srfi-18.test: New file.
+
2008-05-14 Julian Graham <joolean@gmail.com>
* tests/threads.test (mutex-ownership, mutex-lock-levels): New
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
new file mode 100644
index 0000000..d116768
--- /dev/null
+++ b/test-suite/tests/srfi-18.test
@@ -0,0 +1,477 @@
+;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
+;;;; Julian Graham, 2007-10-26
+;;;;
+;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-18)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-18))
+
+(with-test-prefix "current-thread"
+
+ (pass-if "current-thread eq current-thread"
+ (eq? (current-thread) (current-thread))))
+
+(with-test-prefix "thread?"
+
+ (pass-if "current-thread is thread"
+ (thread? (current-thread)))
+
+ (pass-if "foo not thread"
+ (not (thread? 'foo))))
+
+(with-test-prefix "make-thread"
+
+ (pass-if "make-thread creates new thread"
+ (let* ((n (length (all-threads)))
+ (t (make-thread (lambda () 'foo) 'make-thread-1))
+ (r (> (length (all-threads)) n)))
+ (thread-terminate! t) r)))
+
+(with-test-prefix "thread-name"
+
+ (pass-if "make-thread with name binds name"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
+ (r (eq? (thread-name t) 'thread-name-1)))
+ (thread-terminate! t) r))
+
+ (pass-if "make-thread without name does not bind name"
+ (let* ((t (make-thread (lambda () 'foo)))
+ (r (not (thread-name t))))
+ (thread-terminate! t) r)))
+
+(with-test-prefix "thread-specific"
+
+ (pass-if "thread-specific is initially #f"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
+ (r (not (thread-specific t))))
+ (thread-terminate! t) r))
+
+ (pass-if "thread-specific-set! can set value"
+ (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
+ (thread-specific-set! t "hello")
+ (let ((r (equal? (thread-specific t) "hello")))
+ (thread-terminate! t) r))))
+
+(with-test-prefix "thread-start!"
+
+ (pass-if "thread activates only after start"
+ (let* ((started #f)
+ (m (make-mutex 'thread-start-mutex))
+ (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
+ (and (not started) (thread-start! t) (thread-join! t) started))))
+
+(with-test-prefix "thread-yield!"
+
+ (pass-if "thread yield suceeds"
+ (thread-yield!) #t))
+
+(with-test-prefix "thread-sleep!"
+
+ (pass-if "thread sleep with time"
+ (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! future-time))))
+
+ (pass-if "thread sleep with number"
+ (let ((old-secs (car (current-time))))
+ (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
+
+ (pass-if "thread does not sleep on past time"
+ (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! past-time)))))
+
+(with-test-prefix "thread-terminate!"
+
+ (pass-if "termination destroys non-started thread"
+ (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
+ (num-threads (length (all-threads)))
+ (success #f))
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "termination destroys started thread"
+ (let* ((m1 (make-mutex 'thread-terminate-2a))
+ (m2 (make-mutex 'thread-terminate-2b))
+ (c (make-condition-variable 'thread-terminate-2))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m1)
+ (mutex-lock! m2))
+ 'thread-terminate-2))
+ (success #f))
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (thread-start! t)
+ (mutex-unlock! m1 c)
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success)))
+
+(with-test-prefix "thread-join!"
+
+ (pass-if "join receives result of thread"
+ (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
+ (thread-start! t)
+ (eq? (thread-join! t) 'foo)))
+
+ (pass-if "join receives timeout val if timeout expires"
+ (let* ((m (make-mutex 'thread-join-2))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (let ((r (thread-join! t (current-time) 'bar)))
+ (thread-terminate! t)
+ (eq? r 'bar))))
+
+ (pass-if "join throws exception on timeout without timeout val"
+ (let* ((m (make-mutex 'thread-join-3))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
+ (success #f))
+ (mutex-lock! m)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (join-timeout-exception? obj)))
+ (lambda () (thread-join! t (current-time))))
+ (thread-terminate! t)
+ success))
+
+ (pass-if "join waits on timeout"
+ (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
+ (thread-start! t)
+ (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
+
+(with-test-prefix "mutex?"
+
+ (pass-if "make-mutex creates mutex"
+ (mutex? (make-mutex)))
+
+ (pass-if "symbol not mutex"
+ (not (mutex? 'foo))))
+
+(with-test-prefix "mutex-name"
+
+ (pass-if "make-mutex with name binds name"
+ (let* ((m (make-mutex 'mutex-name-1)))
+ (eq? (mutex-name m) 'mutex-name-1)))
+
+ (pass-if "make-mutex without name does not bind name"
+ (let* ((m (make-mutex)))
+ (not (mutex-name m)))))
+
+(with-test-prefix "mutex-specific"
+
+ (pass-if "mutex-specific is initially #f"
+ (let ((m (make-mutex 'mutex-specific-1)))
+ (not (mutex-specific m))))
+
+ (pass-if "mutex-specific-set! can set value"
+ (let ((m (make-mutex 'mutex-specific-2)))
+ (mutex-specific-set! m "hello")
+ (equal? (mutex-specific m) "hello"))))
+
+(with-test-prefix "mutex-state"
+
+ (pass-if "mutex state is initially not-abandoned"
+ (let ((m (make-mutex 'mutex-state-1)))
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex state of locked, owned mutex is owner thread"
+ (let ((m (make-mutex 'mutex-state-2)))
+ (mutex-lock! m)
+ (eq? (mutex-state m) (current-thread))))
+
+ (pass-if "mutex state of locked, unowned mutex is not-owned"
+ (let ((m (make-mutex 'mutex-state-3)))
+ (mutex-lock! m #f #f)
+ (eq? (mutex-state m) 'not-owned)))
+
+ (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
+ (let* ((m (make-mutex 'mutex-state-4))
+ (t (make-thread (lambda () (mutex-lock! m)))))
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'abandoned))))
+
+(with-test-prefix "mutex-lock!"
+
+ (pass-if "mutex-lock! returns true on successful lock"
+ (let* ((m (make-mutex 'mutex-lock-1)))
+ (mutex-lock! m)))
+
+ (pass-if "mutex-lock! returns false on timeout"
+ (let* ((m (make-mutex 'mutex-lock-2))
+ (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (not (thread-join! t))))
+
+ (pass-if "mutex-lock! returns true when lock obtained within timeout"
+ (let* ((m (make-mutex 'mutex-lock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m (+ (time->seconds (current-time))
+ 100)
+ #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m)
+ (thread-join! t)))
+
+ (pass-if "can lock mutex for non-current thread"
+ (let* ((m1 (make-mutex 'mutex-lock-4a))
+ (m2 (make-mutex 'mutex-lock-4b))
+ (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (mutex-lock! m2 #f t)
+ (let ((success (eq? (mutex-state m2) t)))
+ (thread-terminate! t) success)))
+
+ (pass-if "locking abandoned mutex throws exception"
+ (let* ((m (make-mutex 'mutex-lock-5))
+ (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
+ (success #f))
+ (thread-start! t)
+ (thread-join! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-lock! m)))
+ (and success (eq? (mutex-state m) (current-thread)))))
+
+ (pass-if "sleeping threads notified of abandonment"
+ (let* ((m1 (make-mutex 'mutex-lock-6a))
+ (m2 (make-mutex 'mutex-lock-6b))
+ (c (make-condition-variable 'mutex-lock-6))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (condition-variable-signal! c))))
+ (success #f))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
+ success)))
+
+(with-test-prefix "mutex-unlock!"
+
+ (pass-if "unlock changes mutex state"
+ (let* ((m (make-mutex 'mutex-unlock-1)))
+ (mutex-lock! m)
+ (mutex-unlock! m)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "can unlock from any thread"
+ (let* ((m (make-mutex 'mutex-unlock-2))
+ (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex unlock is true when condition is signalled"
+ (let* ((m (make-mutex 'mutex-unlock-3))
+ (c (make-condition-variable 'mutex-unlock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c)))
+
+ (pass-if "mutex unlock is false when condition times out"
+ (let* ((m (make-mutex 'mutex-unlock-4))
+ (c (make-condition-variable 'mutex-unlock-4)))
+ (mutex-lock! m)
+ (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+
+(with-test-prefix "condition-variable?"
+
+ (pass-if "make-condition-variable creates condition variable"
+ (condition-variable? (make-condition-variable)))
+
+ (pass-if "symbol not condition variable"
+ (not (condition-variable? 'foo))))
+
+(with-test-prefix "condition-variable-name"
+
+ (pass-if "make-condition-variable with name binds name"
+ (let* ((c (make-condition-variable 'condition-variable-name-1)))
+ (eq? (condition-variable-name c) 'condition-variable-name-1)))
+
+ (pass-if "make-condition-variable without name does not bind name"
+ (let* ((c (make-condition-variable)))
+ (not (condition-variable-name c)))))
+
+(with-test-prefix "condition-variable-specific"
+
+ (pass-if "condition-variable-specific is initially #f"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (not (condition-variable-specific c))))
+
+ (pass-if "condition-variable-specific-set! can set value"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (condition-variable-specific-set! c "hello")
+ (equal? (condition-variable-specific c) "hello"))))
+
+(with-test-prefix "condition-variable-signal!"
+
+ (pass-if "condition-variable-signal! wakes up single thread"
+ (let* ((m (make-mutex 'condition-variable-signal-1))
+ (c (make-condition-variable 'condition-variable-signal-1))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c))))
+
+(with-test-prefix "condition-variable-broadcast!"
+
+ (pass-if "condition-variable-broadcast! wakes up multiple threads"
+ (let* ((sem 0)
+ (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
+ (m1 (make-mutex 'condition-variable-broadcast-1-a))
+ (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
+ (m2 (make-mutex 'condition-variable-broadcast-1-b))
+ (inc-sem! (lambda ()
+ (mutex-lock! m1)
+ (set! sem (+ sem 1))
+ (condition-variable-broadcast! c1)
+ (mutex-unlock! m1)))
+ (dec-sem! (lambda ()
+ (mutex-lock! m1)
+ (while (eqv? sem 0) (wait-condition-variable c1 m1))
+ (set! sem (- sem 1))
+ (mutex-unlock! m1)))
+ (t1 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!))))
+ (t2 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!)))))
+ (thread-start! t1)
+ (thread-start! t2)
+ (dec-sem!)
+ (dec-sem!)
+ (mutex-lock! m2)
+ (condition-variable-broadcast! c2)
+ (mutex-unlock! m2)
+ (dec-sem!)
+ (dec-sem!))))
+
+(with-test-prefix "time?"
+
+ (pass-if "current-time is time" (time? (current-time)))
+ (pass-if "number is not time" (not (time? 123)))
+ (pass-if "symbol not time" (not (time? 'foo))))
+
+(with-test-prefix "time->seconds"
+
+ (pass-if "time->seconds makes time into rational"
+ (rational? (time->seconds (current-time))))
+
+ (pass-if "time->seconds is reversible"
+ (let ((t (current-time)))
+ (equal? t (seconds->time (time->seconds t))))))
+
+(with-test-prefix "seconds->time"
+
+ (pass-if "seconds->time makes rational into time"
+ (time? (seconds->time 123.456)))
+
+ (pass-if "seconds->time is reversible"
+ (let ((t (time->seconds (current-time))))
+ (equal? t (time->seconds (seconds->time t))))))
+
+(with-test-prefix "current-exception-handler"
+
+ (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 "exception handler installation is thread-safe"
+ (let* ((h1 (current-exception-handler))
+ (h2 (lambda (key . args) 'nothing-2))
+ (m (make-mutex 'current-exception-handler-4))
+ (c (make-condition-variable 'current-exception-handler-4))
+ (t (make-thread (lambda ()
+ (with-exception-handler
+ h2 (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h2)
+ (mutex-unlock! m)))))
+ 'current-exception-handler-4)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)
+ (thread-join! t)))))
+
+(with-test-prefix "uncaught-exception-reason"
+
+ (pass-if "initial handler captures top level exception"
+ (let ((t (make-thread (lambda () (raise 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "initial handler captures non-SRFI-18 throw"
+ (let ((t (make-thread (lambda () (throw 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success)))
--
1.5.4.3
next prev parent reply other threads:[~2008-05-15 5:05 UTC|newest]
Thread overview: 75+ messages / expand[flat|nested] mbox.gz Atom feed top
2007-10-11 1:54 srfi-18 requirements Julian Graham
2007-10-12 8:42 ` Ludovic Courtès
2007-10-12 15:31 ` Julian Graham
2007-10-15 22:26 ` Julian Graham
2007-10-15 22:35 ` Stephen Compall
2007-10-15 22:47 ` Julian Graham
2007-10-29 14:37 ` Julian Graham
2007-11-26 18:11 ` Julian Graham
2007-11-27 9:14 ` Ludovic Courtès
2007-11-28 18:23 ` Ludovic Courtès
2007-11-28 18:55 ` Julian Graham
2007-12-01 5:08 ` Julian Graham
2007-12-01 10:21 ` Ludovic Courtès
2007-12-02 3:59 ` Julian Graham
2007-12-04 22:20 ` Neil Jerram
2007-12-04 22:29 ` Neil Jerram
2007-12-11 4:20 ` Julian Graham
2007-12-18 4:30 ` Julian Graham
2007-12-28 18:46 ` Ludovic Courtès
2007-12-28 19:08 ` Julian Graham
2007-12-28 22:35 ` Neil Jerram
2007-12-30 11:04 ` Neil Jerram
2007-12-30 20:38 ` Julian Graham
2008-01-01 19:09 ` Neil Jerram
2008-01-04 5:01 ` Julian Graham
2008-01-05 0:30 ` Neil Jerram
2008-01-06 21:41 ` Julian Graham
2008-01-08 23:11 ` Neil Jerram
2008-01-11 2:39 ` Julian Graham
2008-01-17 1:48 ` Neil Jerram
2008-01-19 20:10 ` Julian Graham
2008-01-23 22:46 ` Neil Jerram
2008-01-23 23:23 ` Julian Graham
2008-01-25 1:07 ` Neil Jerram
2008-01-25 1:38 ` Julian Graham
2008-01-28 2:06 ` Julian Graham
2008-02-03 0:30 ` Neil Jerram
2008-02-05 6:27 ` Julian Graham
2008-02-07 1:23 ` Neil Jerram
2008-02-07 3:06 ` Julian Graham
2008-02-07 23:26 ` Neil Jerram
2008-02-07 23:33 ` Julian Graham
2008-02-07 23:38 ` Neil Jerram
2008-02-08 0:04 ` Julian Graham
2008-02-11 5:14 ` Julian Graham
2008-02-19 22:48 ` Neil Jerram
2008-02-20 2:10 ` Julian Graham
2008-02-22 0:33 ` Neil Jerram
2008-02-22 4:14 ` Julian Graham
2008-02-24 9:41 ` Neil Jerram
2008-02-24 18:17 ` Julian Graham
2008-02-24 23:29 ` Neil Jerram
2008-03-01 19:56 ` Julian Graham
2008-03-08 16:34 ` Neil Jerram
2008-03-11 4:02 ` Julian Graham
2008-03-22 18:55 ` Julian Graham
2008-03-23 23:57 ` Neil Jerram
2008-03-24 22:03 ` Neil Jerram
2008-03-26 15:55 ` Julian Graham
2008-04-03 0:18 ` Neil Jerram
2008-04-03 19:07 ` Julian Graham
2008-04-09 21:29 ` Neil Jerram
2008-04-14 0:43 ` Julian Graham
2008-05-14 1:23 ` Julian Graham
2008-05-14 21:13 ` Neil Jerram
2008-05-14 23:11 ` Neil Jerram
2008-05-15 5:05 ` Julian Graham [this message]
2008-05-24 11:42 ` Neil Jerram
2008-05-24 13:55 ` Neil Jerram
2008-05-25 2:07 ` Julian Graham
2008-05-31 21:41 ` Ludovic Courtès
2008-06-02 4:48 ` Julian Graham
2008-06-21 5:03 ` Julian Graham
2008-06-30 17:51 ` Ludovic Courtès
2008-01-08 23:41 ` Neil Jerram
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=2bc5f8210805142205o4bfd13f1x5f449a7ad6b64700@mail.gmail.com \
--to=joolean@gmail.com \
--cc=guile-devel@gnu.org \
--cc=ludo@gnu.org \
--cc=neil@ossau.uklinux.net \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).