Commit 563037be authored by eg's avatar eg

Threads: documentation + tests

parent 6a312402
......@@ -2,13 +2,13 @@
#
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 1-Sep-2004 16:19 (eg)
# Last file update: 4-Jan-2006 14:08 (eg)
# Last file update: 24-Oct-2006 21:10 (eg)
SOURCES = biblio.skb cond.skb custom.skb expr.skb index.skb \
intro.skb match.skb object.skb \
overview.skb progstruct.skb regexp.skb slib.skb srfi.skb \
stdproc.skb stklos.skb
stdproc.skb stklos.skb threads.skb
BIB = biblio.skbib
DOCDB = ../DOCDB
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Aug-2004 12:43 (eg)
;;;; Last file update: 3-Jan-2006 16:22 (eg)
;;;; Last file update: 24-Oct-2006 14:51 (eg)
;;;;
(define srfi-address "http://srfi.schemers.org/srfi-~A/srfi-~A.html")
......@@ -41,6 +41,7 @@
(14 . "Character-Set Library")
(16 . "Syntax for procedures of variable arity")
(17 . "Generalized set!")
(18 . "Multithreading support")
(22 . "Running Scheme Scripts on Unix")
(23 . "Error reporting mechanism")
(26 . "Notation for Specializing Parameters without Currying")
......
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 12-Sep-2006 15:27 (eg)
;; Last file update: 24-Oct-2006 21:08 (eg)
;;
;; ======================================================================
......@@ -761,15 +761,15 @@ See SRFI document for more information.])
(insertdoc 'error)
(insertdoc 'require-extension)
(insertdoc 'repl)
(insertdoc 'apropos)
(insertdoc 'trace)
(insertdoc 'untrace)
(insertdoc 'pp)
(insertdoc 'uri-parse)
(insertdoc 'string->html))
(insertdoc 'string->html)
(insertdoc 'base64-encode)
(insertdoc 'base64-decode)
(insertdoc 'base64-encode-string)
(insertdoc 'base64-decode-string)
(insertdoc 'base64-decode-string) )
)
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 27-May-2005 11:22 (eg)
;; Last file update: 24-Oct-2006 20:12 (eg)
;;
;; ======================================================================
......@@ -80,6 +80,7 @@ document.]
(skribe-include "match.skb")
(skribe-include "cond.skb")
(skribe-include "object.skb")
(skribe-include "threads.skb")
(skribe-include "custom.skb")
(skribe-include "slib.skb")
(skribe-include "srfi.skb")
......
;; ======================================================================
;;
;; STklos Reference Manual
;;
;; 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 of the License, 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 program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 25-Oct-2006 16:17 (eg)
;;
;; ======================================================================
(chapter :title "Threads, Mutexes and Condition Variables"
(index "thread")
(index "mutex")
(index "lock")
(index "condition variable")
(p [The thread system provides the following data types:]
(itemize
(item [ Thread (a virtual processor which shares object
space with all other threads)])
(item [Mutex (a mutual exclusion device,
also known as a lock and binary semaphore)])
(item [Condition variable (a set of blocked threads)])))
(p [The ,(stklos) thread system is conform to ,(link-srfi 18), and implement
all the SRFI mechanisms. See this SRFI documentation for a more complete
description])
(section :title "Threads"
(insertdoc 'make-thread)
(insertdoc 'current-thread)
(insertdoc 'thread-start!)
(insertdoc 'thread-yield!)
(insertdoc 'thread-terminate!)
(insertdoc 'thread-sleep!)
(insertdoc 'thread-join!)
(insertdoc 'thread?)
(insertdoc 'thread-name)
(insertdoc 'thread-stack-size)
(insertdoc 'thread-specific)
(insertdoc 'thread-specific-set!))
(section :title "Mutexes"
(insertdoc 'make-mutex)
(insertdoc 'mutex?)
(insertdoc 'mutex-name)
(insertdoc 'mutex-specific)
(insertdoc 'mutex-specific-set!)
(insertdoc 'mutex-state)
(insertdoc 'mutex-lock!)
(insertdoc 'mutex-unlock!))
(section :title "Condition Variables"
(insertdoc 'make-condition-variable)
(insertdoc 'condition-variable?)
(insertdoc 'condition-variable-name)
(insertdoc 'condition-variable-specific)
(insertdoc 'condition-variable-specific-set!)
(insertdoc 'condition-variable-signal!)
(insertdoc 'condition-variable-broadcast!))
(section :title "Conditions"
(insertdoc 'join-timeout-exception?)
(insertdoc 'abandoned-mutex-exception?)
(insertdoc 'terminated-thread-exception?)
(insertdoc 'uncaught-exception?)
(insertdoc 'uncaught-exception-reason))
)
\ No newline at end of file
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 27-Sep-2006 14:02 (eg)
# Last file update: 23-Oct-2006 23:11 (eg)
SUBDIRS = Match.d SILex.d Lalr.d @LURCDIR@
......@@ -10,6 +10,7 @@ scheme_BOOT = assembler.stk \
bb.stk \
bonus.stk \
boot.stk \
callcc.stk \
compiler.stk \
computils.stk \
date.stk \
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 27-Sep-2006 14:02 (eg)
# Last file update: 23-Oct-2006 23:11 (eg)
srcdir = @srcdir@
top_srcdir = @top_srcdir@
......@@ -202,6 +202,7 @@ scheme_BOOT = assembler.stk \
bb.stk \
bonus.stk \
boot.stk \
callcc.stk \
compiler.stk \
computils.stk \
date.stk \
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 26-Sep-2006 19:36 (eg)
;;;; Last file update: 23-Oct-2006 15:33 (eg)
;;;;
;;;
......@@ -218,8 +218,6 @@
;;;;
;;;; Utilities
;;;;
(define *lab-equiv* '()) ;FIXME: virer?
(define (info-opcode name)
(let ((v (assq name INSTRUCTION-SET)))
(if v
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Jun-2000 17:24 (eg)
;;;; Last file update: 11-Sep-2006 17:23 (eg)
;;;; Last file update: 24-Oct-2006 20:34 (eg)
;;;;
;;
......@@ -1159,7 +1159,7 @@ doc>
* on a Unix system:
* @lisp
* (make-path "a" "b" "c") => "a/b/c"
* @lisp
* @end lisp
doc>
|#
(define (make-path dirname . names)
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 3-Apr-2006 12:27 (eg)
;;;; Last file update: 14-Apr-2006 19:53 (eg)
;;;; Last file update: 24-Oct-2006 17:33 (eg)
;;;;
(define (%call/cc proc)
......@@ -32,41 +32,37 @@
(%restore-continuation k v)))
(apply values k))))
;(define %dynamic-wind-stack (make-parameter (list #f)))
(define call/cc #f)
(define call-with-current-continuation #f)
(define dynamic-wind #f)
(let ((*here* (list #f)))
(let ()
(define (reroot! there)
(unless (eq? *here* there)
(reroot! (cdr there))
(let ((before (caar there))
(after (cdar there)))
(set-car! *here* (cons after before))
(set-cdr! *here* there)
(set-car! there #f)
(set-cdr! there '())
(set! *here* there)
(before))))
(unless (eq? (%thread-dynwind-stack) there)
(reroot! (cdr there))
(let ((before (caar there))
(after (cdar there))
(here (%thread-dynwind-stack)))
(set-car! here (cons after before))
(set-cdr! here there)
(set-car! there #f)
(set-cdr! there '())
(%thread-dynwind-stack-set! there)
(before))))
;;
;; call/cc
;;
(set! call/cc
(lambda (proc)
(let ((here *here*))
(let ((here (%thread-dynwind-stack)))
(%call/cc (lambda (cont)
(proc (lambda results
(reroot! here)
(apply cont results))))))))
;;
;; call-with-current-continuation
;;
(set! call-with-current-continuation call/cc)
;;
;; dynamic-wind
;;
......@@ -80,7 +76,7 @@
(verify-proc during)
(verify-proc after)
(let ((here *here*))
(let ((here (%thread-dynwind-stack)))
(reroot! (cons (cons before after) here))
(with-handler (lambda (c)
(reroot! here)
......@@ -88,3 +84,8 @@
(call-with-values during
(lambda results (reroot! here) (apply values results))))))))
;;
;; call-with-current-continuation
;;
(define call-with-current-continuation call/cc)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 26-Jan-2006 22:56 (eg)
;;;; Last file update: 21-Oct-2006 11:31 (eg)
;;;; Last file update: 25-Oct-2006 15:43 (eg)
;;;;
(define (%thread-timeout->seconds timeout)
(cond
......@@ -31,7 +31,34 @@
timeout))
(else (error "bad timeout ~S" timeout))))
#|
<doc EXT make-thread
* (make-thread thunk)
* (make-thread thunk name)
* (make-thread thunk name stack-size)
*
* Returns a new thread. This thread is not automatically made runnable
* (the procedure |thread-start!| must be used for this). A thread has the
* following fields: name, specific, end-result, end-exception, and a list
* of locked/owned mutexes it owns. The thread's execution consists of a call
* to thunk with the "initial continuation". This continuation causes the
* (then) current thread to store the result in its end-result field, abandon
* all mutexes it owns, and finally terminate. The dynamic-wind
* stack of the initial continuation is empty. The optional name is an
* arbitrary Scheme object which identifies the thread (useful for debugging)\;
* it defaults to an unspecified value. The specific field is set to an
* unspecified value. The thread inherits the dynamic environment from the
* current thread. Moreover, in this dynamic environment the exception handler
* is bound to the "initial exception handler" which is a unary procedure
* which causes the (then) current thread to store in its end-exception
* field an "uncaught exception" object whose "reason" is the argument
* of the handler, abandon all mutexes it owns, and finally terminate.
* £
* ,(bold "Note:") The optional parameter |stack-size| permits to specify
* the size (in words) reserved for the thread. This option does not exist
* in ,(quick-link-srfi 18).
doc>
|#
(define (make-thread thunk :optional (name (symbol->string (gensym "thread")))
stack-size)
(define (thread-handler c)
......@@ -39,9 +66,9 @@
c)
(%make-thread (lambda ()
(with-handler thread-handler
(thunk)))
name
stack-size))
(thunk)))
name
stack-size))
(define (thread-sleep! timeout)
......@@ -63,13 +90,20 @@
timeout-val
(raise (make-condition &thread-join-timeout))))
((%thread-end-exception thread)
;; We had an exceptionin thread. Raise it
(raise (%thread-end-exception thread)))
;; We had an exception in thread. Raise an uncaught-exception
(eprintf "FOOOOO\n")
(let ((old-exception (%thread-end-exception thread)))
(raise (make-condition &uncaught-exception
'reason old-exception))))
(else
;; No exception. Return the thread-result
(%thread-end-result thread))))))
;; **********************************************************************
;;
;; Mutexes
;;
;; **********************************************************************
(define (mutex-lock! mtx :optional timeout (thread (current-thread)))
(let ((res (%mutex-lock! mtx (%thread-timeout->seconds timeout) thread)))
......@@ -83,3 +117,62 @@
(define (mutex-unlock! mtx :optional condv timeout)
(%mutex-unlock! mtx condv timeout))
;; **********************************************************************
;;
;; Conditions
;;
;; **********************************************************************
(%define-condition-type-accessors &thread-join-timeout &condition
join-timeout-exception?)
(%define-condition-type-accessors &thread-abandonned-mutex &condition
abandoned-mutex-exception?)
(%define-condition-type-accessors &thread-terminated &condition
terminated-thread-exception?)
(define &uncaught-exception
(make-condition-type '&uncaught-execption
&condition
'(reason)))
#|
<doc EXT join-timeout-exception?
* (join-timeout-exception? obj)
*
* Returns #t if |obj| is a "join timeout exception" object, otherwise returns #f.
* A join timeout exception is raised when thread-join! is called, the timeout
* is reached and no timeout-val is supplied.
doc>
<doc EXT abandoned-mutex-exception?
* (abandoned-mutex-exception? obj)
*
* Returns #t if |obj| is an "abandoned mutex exception" object, otherwise returns
* #f. An abandoned mutex exception is raised when the current thread locks
* a mutex that was owned by a thread which terminated (see |mutex-lock!|).
doc>
<doc EXT terminated-thread-exception?
* (terminated-thread-exception? obj)
*
* Returns #t if |obj| is a "terminated thread exception" object, otherwise
* returns #f. A terminated thread exception is raised when thread-join! is
* called and the target thread has terminated as a result of a call to
* |thread-terminate!|.
doc>
<doc EXT uncaught-exception?
* (uncaught-exception? obj)
*
* Returns #t if |obj| is an "uncaught exception" object, otherwise returns
* #f. An uncaught exception is raised when |thread-join!| is called and the
* target thread has terminated because it raised an exception that called
* the initial exception handler of that thread.
doc>
<doc EXT uncaught-exception-reason
* (uncaught-exception-reason exc)
*
* Returns the object which was passed to the initial exception handler
* of that thread (exc must be an "uncaught exception" object).
doc>
|#
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 17-Apr-2006 00:00 (eg)
* Last file update: 25-Oct-2006 16:22 (eg)
*/
#include <unistd.h>
......@@ -55,6 +55,17 @@ void STk_error_bad_timeout(SCM tm)
/* ====================================================================== */
/*
<doc EXT make-mutex
* (make-mutex)
* (make-mutex name)
*
* Returns a new mutex in the unlocked/not-abandoned state. The optional |name|
* is an arbitrary Scheme object which identifies the mutex
* (useful for debugging); it defaults to an unspecified value.
* The mutex's specific field is set to an unspecified value.
doc>
*/
DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
{
SCM z;
......@@ -70,23 +81,74 @@ DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
return z;
}
/*
<doc EXT mutex?
* (mutex? obj)
*
* Returns |#t| if obj is a mutex, otherwise returns |#f|.
doc>
*/
DEFINE_PRIMITIVE("mutex?", mutexp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(MUTEXP(obj));
}
/*
<doc EXT mutex-name
* (mutex-name mutex)
*
* Returns the name of the |mutex|.
* @lisp
* (mutex-name (make-mutex 'foo)) => foo
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("mutex-name", mutex_name, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
return MUTEX_NAME(mtx);
}
/*
<doc EXT mutex-specific
* (mutex-specific mutex)
*
* Returns the content of the |mutex|'s specific field.
doc>
*/
DEFINE_PRIMITIVE("mutex-specific", mutex_specific, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
return MUTEX_SPECIFIC(mtx);
}
/*
<doc EXT mutex-specific-set!
* (mutex-specific! mutex obj)
*
* Stores |obj| into the |mutex|'s specific field and eturns an unspecified value.
* @lisp
* (define m (make-mutex))
* (mutex-specific-set! m "hello") => unspecified
* (mutex-specific m) => "hello"
*
* (define (mutex-lock-recursively! mutex)
* (if (eq? (mutex-state mutex) (current-thread))
* (let ((n (mutex-specific mutex)))
* (mutex-specific-set! mutex (+ n 1)))
* (begin
* (mutex-lock! mutex)
* (mutex-specific-set! mutex 0))))
*
* (define (mutex-unlock-recursively! mutex)
* (let ((n (mutex-specific mutex)))
* (if (= n 0)
* (mutex-unlock! mutex)
* (mutex-specific-set! mutex (- n 1)))))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("mutex-specific-set!", mutex_specific_set, subr2, (SCM mtx, SCM v))
{
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
......@@ -106,8 +168,18 @@ void STk_error_bad_condv(SCM obj)
STk_error("bad confdition variable ~S", obj);
}
/* ====================================================================== */
/*
<doc EXT make-condition-variable
* (make-conditon-variable)
* (make-conditon-variable name)
*
* Returns a new empty condition variable. The optional |name| is an arbitrary
* Scheme object which identifies the condition variable (useful for debugging);
* it defaults to an unspecified value. The condition variable's specific
* field is set to an unspecified value.
doc>
*/
DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
{
SCM z;
......@@ -122,23 +194,53 @@ DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
}
/*
<doc EXT condition-variable?
* (conditon-variable? obj)
*
* Returns |#t| if |obj| is a condition variable, otherwise returns |#f|.
doc>
*/
DEFINE_PRIMITIVE("condition-variable?", condvp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(CONDVP(obj));
}
/*
<doc EXT condition-variable-name
* (conditon-variable-name conditon-variable)
*
*Returns the name of the |condition-variable|.
doc>
*/
DEFINE_PRIMITIVE("condition-variable-name", condv_name, subr1, (SCM cv))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
return CONDV_NAME(cv);
}
/*
<doc EXT condition-variable-specific
* (conditon-variable-specific conditon-variable)
*
* Returns the content of the |condition-variable|'s specific field.
doc>
*/
DEFINE_PRIMITIVE("condition-variable-specific", condv_specific, subr1, (SCM cv))
{
if (! CONDVP(cv)) STk_error_bad_condv(cv);
return CONDV_SPECIFIC(cv);
}
/*
<doc EXT condition-variable-specific-set!
* (conditon-variable-specific-set! conditon-variable obj)
*
* Stores |obj| into the |condition-variable|'s specific field.
doc>
*/
DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
(SCM cv, SCM v))
{
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 2-May-2006 16:52 (eg)
* Last file update: 25-Oct-2006 16:22 (eg)
*/
#include <unistd.h>
......@@ -48,9 +48,36 @@ void STk_make_sys_mutex(SCM z)
pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
pthread_cond_init(&MUTEX_MYCONDV(z), NULL);
//FINAL STk_register_finalizer(z, mutex_finalizer);
// STk_register_finalizer(z, mutex_finalizer);
}
/*
<doc EXT mutex-state
* (mutex-state mutex)
*
* Returns information about the state of the |mutex|. The possible results
* are:
* ,(itemize
* (item [,(bold "thread T"): the mutex is in the locked/owned state and
* thread T is the owner of the mutex])
* (item [,(bold "symbol not-owned"): the mutex is in the locked/not-owned
* state])
* (item [,(bold "symbol abandoned"): the mutex is in the unlocked/abandoned
* state])
* (item [,(bold "symbol not-abandoned"): the mutex is in the
* unlocked/not-abandoned state]))
* @lisp
* (mutex-state (make-mutex)) => not-abandoned
*
* (define (thread-alive? thread)
* (let ((mutex (make-mutex)))
* (mutex-lock! mutex #f thread)
* (let ((state (mutex-state mutex)))
* (mutex-unlock! mutex) ; avoid space leak
* (eq? state thread))))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
{
SCM res;
......@@ -59,6 +86,13 @@ DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
pthread_mutex_lock(&MUTEX_MYMUTEX(mtx));
if (MUTEX_LOCKED(mtx) &&
(MUTEX_OWNER(mtx) != STk_false) &&
(THREAD_STATE(MUTEX_OWNER(mtx)) == th_terminated)) {
/* The thread which owns this mutex is terminated => Unlock the mutex */
MUTEX_LOCKED(mtx) = FALSE;
}
if (MUTEX_LOCKED(mtx))
res = (MUTEX_OWNER(mtx) == STk_false) ? STk_sym_not_owned : MUTEX_OWNER(mtx);
else
......@@ -70,6 +104,36 @@ DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
}
/*
<doc EXT mutex-lock!
* (mutex-lock! mutex)
* (mutex-lock! mutex timeout)
* (mutex-lock! mutex timeout thread)
*
* If the |mutex| is currently locked, the current thread waits until the
* |mutex| is unlocked, or until the timeout is reached if |timeout| is supplied.
* If the |timeout| is reached, |mutex-lock!| returns |#f|.
* Otherwise, the state of the mutex is changed as follows:
* ,(itemize
* (item [if thread is |#f| the mutex becomes locked/not-owned,])
* (item [otherwise, let T be thread (or the current thread if thread
* is not supplied),
* ,(itemize
* (item [if T is terminated the mutex becomes unlocked/abandoned,])
* (item [otherwise mutex becomes locked/owned with T as the owner.]))]))
*
* After changing the state of the mutex, an "abandoned mutex exception" is
* raised if the mutex was unlocked/abandoned before the state change,
* otherwise |mutex-lock!| returns |#t|.
* @lisp
* (define (sleep! timeout)
* ;; an alternate implementation of thread-sleep!
* (let ((m (make-mutex)))
* (mutex-lock! m #f #f)
* (mutex-lock! m timeout #f)))
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread))
{
struct timespec ts;
......@@ -122,6 +186,25 @@ DEFINE_PRIMITIVE("%mutex-lock!", mutex_lock, subr3, (SCM mtx, SCM tm, SCM thread
return res;
}
/*
<doc EXT mutex-unlock!
* (mutex-unlock! mutex)
* (mutex-unlock! mutex condition-variable)
* (mutex-unlock! mutex condition-variable timeout)
*
* Unlocks the |mutex| by making it unlocked/not-abandoned. It is not an error
* to unlock an unlocked mutex and a mutex that is owned by any thread.
* If |condition-variable| is supplied, the current thread is blocked and
* added to the |condition-variable| before unlocking |mutex|; the thread
* can unblock at any time but no later than when an appropriate call to
* |condition-variable-signal!| or |condition-variable-broadcast!| is
* performed (see below), and no later than the timeout (if timeout is
* supplied). If there are threads waiting to lock this mutex, the scheduler
* selects a thread, the |mutex| becomes locked/owned or locked/not-owned,
* and the thread is unblocked. |mutex-unlock!| returns |#f| when the
* |timeout| is reached, otherwise it returns |#t|.
doc>
*/
DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm))
{
struct timespec ts;
......@@ -129,6 +212,7 @@ DEFINE_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
SCM res = STk_true;
if (! MUTEXP(mtx)) STk_error_bad_mutex(mtx);
if ((cv != STk_false) && (!CONDVP(cv))) STk_error_bad_condv(cv);
if (REALP(tm)) {
tmd = REAL_VAL(tm);
ts.tv_sec = (time_t) tmd;
......@@ -178,9 +262,19 @@ void STk_make_sys_condv(SCM z)
{
pthread_cond_init(&CONDV_MYCONDV(z), NULL);
//FINAL STk_register_finalizer(z, condv_finalizer);
// STk_register_finalizer(z, condv_finalizer);
}
/*
<doc EXT condition-variable-signal!
* (condition-variable-signal! condition-variable)
*
* If there are threads blocked on the |condition-variable|, the scheduler
* selects a thread and unblocks it. |Condition-variable-signal!| returns
* an unspecified value.
doc>
*/
DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))