Commit c391ba14 authored by eg's avatar eg

Adding mutexes & condv

parent 9c86f251
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 23-Jan-2006 12:15 (eg)
# Last file update: 2-Feb-2006 21:59 (eg)
CC = @CC@
CFLAGS = @CFLAGS@
......@@ -19,10 +19,10 @@ DOCDB = DOCDB
stklos_SOURCES = boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c number.c object.c parameter.c path.c port.c print.c \
list.c misc.c mutex.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
symbol.c system.c threads.c uvector.c vector.c vm.c vport.c
symbol.c system.c thread.c uvector.c vector.c vm.c vport.c
### # The STklos library
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 23-Jan-2006 12:15 (eg)
# Last file update: 2-Feb-2006 21:59 (eg)
SHELL = @SHELL@
srcdir = @srcdir@
......@@ -131,10 +131,10 @@ DOCDB = DOCDB
stklos_SOURCES = boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c number.c object.c parameter.c path.c port.c print.c \
list.c misc.c mutex.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
symbol.c system.c threads.c uvector.c vector.c vm.c vport.c
symbol.c system.c thread.c uvector.c vector.c vm.c vport.c
### # The STklos library
......@@ -181,14 +181,15 @@ am_stklos_OBJECTS = boolean.$(OBJEXT) boot.$(OBJEXT) char.$(OBJEXT) \
cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) error.$(OBJEXT) \
extend.$(OBJEXT) fport.$(OBJEXT) gnu-getopt.$(OBJEXT) \
gnu-glob.$(OBJEXT) hash.$(OBJEXT) keyword.$(OBJEXT) \
lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) number.$(OBJEXT) \
object.$(OBJEXT) parameter.$(OBJEXT) path.$(OBJEXT) \
port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) process.$(OBJEXT) \
promise.$(OBJEXT) read.$(OBJEXT) regexp.$(OBJEXT) \
signal.$(OBJEXT) sio.$(OBJEXT) socket.$(OBJEXT) sport.$(OBJEXT) \
stklos.$(OBJEXT) str.$(OBJEXT) struct.$(OBJEXT) \
symbol.$(OBJEXT) system.$(OBJEXT) threads.$(OBJEXT) \
uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) vport.$(OBJEXT)
lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) mutex.$(OBJEXT) \
number.$(OBJEXT) object.$(OBJEXT) parameter.$(OBJEXT) \
path.$(OBJEXT) port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) \
process.$(OBJEXT) promise.$(OBJEXT) read.$(OBJEXT) \
regexp.$(OBJEXT) signal.$(OBJEXT) sio.$(OBJEXT) \
socket.$(OBJEXT) sport.$(OBJEXT) stklos.$(OBJEXT) str.$(OBJEXT) \
struct.$(OBJEXT) symbol.$(OBJEXT) system.$(OBJEXT) \
thread.$(OBJEXT) uvector.$(OBJEXT) vector.$(OBJEXT) \
vm.$(OBJEXT) vport.$(OBJEXT)
stklos_OBJECTS = $(am_stklos_OBJECTS)
stklos_DEPENDENCIES =
......@@ -207,19 +208,19 @@ am__depfiles_maybe = depfiles
@AMDEP_TRUE@ ./$(DEPDIR)/gnu-glob.Po ./$(DEPDIR)/hash.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/keyword.Po ./$(DEPDIR)/lib.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/list.Po ./$(DEPDIR)/misc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/number.Po ./$(DEPDIR)/object.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/parameter.Po ./$(DEPDIR)/path.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/port.Po ./$(DEPDIR)/print.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/proc.Po ./$(DEPDIR)/process.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/promise.Po ./$(DEPDIR)/read.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/regexp.Po ./$(DEPDIR)/signal.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/sio.Po ./$(DEPDIR)/socket.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/sport.Po ./$(DEPDIR)/stklos.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/str.Po ./$(DEPDIR)/struct.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/symbol.Po ./$(DEPDIR)/system.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/threads.Po ./$(DEPDIR)/uvector.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/vector.Po ./$(DEPDIR)/vm.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/vport.Po
@AMDEP_TRUE@ ./$(DEPDIR)/mutex.Po ./$(DEPDIR)/number.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/object.Po ./$(DEPDIR)/parameter.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/path.Po ./$(DEPDIR)/port.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/print.Po ./$(DEPDIR)/proc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/process.Po ./$(DEPDIR)/promise.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/read.Po ./$(DEPDIR)/regexp.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/signal.Po ./$(DEPDIR)/sio.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/socket.Po ./$(DEPDIR)/sport.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/stklos.Po ./$(DEPDIR)/str.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/struct.Po ./$(DEPDIR)/symbol.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/system.Po ./$(DEPDIR)/thread.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/uvector.Po ./$(DEPDIR)/vector.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/vm.Po ./$(DEPDIR)/vport.Po
COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
$(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
CCLD = $(CC)
......@@ -310,6 +311,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/lib.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/list.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/misc.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mutex.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/number.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/object.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/parameter.Po@am__quote@
......@@ -330,7 +332,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/struct.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/symbol.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/system.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/threads.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/thread.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/uvector.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/vector.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/vm.Po@am__quote@
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 1-Feb-2006 18:02 (eg)
* Last file update: 2-Feb-2006 22:25 (eg)
*/
......@@ -74,8 +74,9 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_boolean() &&
STk_init_reader() &&
STk_init_system() &&
STk_init_vm(stack_size) && //FIX: Ne sert pas
STk_init_vm() &&
STk_init_threads(stack_size)&&
STk_init_mutexes() &&
STk_init_hash() &&
STk_init_misc() &&
STk_init_signal() &&
......
/*
* mutex.c -- Pthread Mutexes in Scheme
*
* Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* 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@essi.fr]
* Creation date: 2-Feb-2006 21:58 (eg)
* Last file update: 3-Feb-2006 10:55 (eg)
*/
#define _REENTRANT 1
#define GC_LINUX_THREADS 1
#include <pthread.h>
#include <unistd.h>
#include "stklos.h"
#include "vm.h"
static SCM sym_not_owned, sym_abandoned, sym_not_abandoned;
/* ====================================================================== *\
*
* M U T E X E S
*
\* ====================================================================== */
struct mutex_obj {
stk_header header;
SCM name;
SCM specific;
SCM owner;
int locked;
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
};
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define MUTEX_NAME(p) (((struct mutex_obj *) (p))->name)
#define MUTEX_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define MUTEX_OWNER(p) (((struct mutex_obj *) (p))->owner)
#define MUTEX_LOCKED(p) (((struct mutex_obj *) (p))->locked)
#define MUTEX_MYMUTEX(p) (((struct mutex_obj *) (p))->mymutex)
#define MUTEX_MYCONDV(p) (((struct mutex_obj *) (p))->mycondv)
void error_bad_mutex(SCM obj)
{
STk_error("bad mutex ~S", obj);
}
void mutex_finalizer(SCM mtx)
{
STk_debug("Finalizer mutex ~S", mtx);
pthread_mutex_destroy(&MUTEX_MYMUTEX(mtx));
pthread_cond_destroy(&MUTEX_MYCONDV(mtx));
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
{
SCM z;
if (name) {
if (!STRINGP(name))
STk_error("bad mutex name ~S", name);
}
else name = STk_Cstring2string("");
NEWCELL(z, mutex);
MUTEX_NAME(z) = name;
MUTEX_SPECIFIC(z) = STk_void;
MUTEX_OWNER(z) = STk_void;
MUTEX_LOCKED(z) = FALSE;
pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
pthread_cond_init(&MUTEX_MYCONDV(z), NULL);
STk_register_finalizer(z, mutex_finalizer);
return z;
}
DEFINE_PRIMITIVE("mutex?", mutexp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(MUTEXP(obj));
}
DEFINE_PRIMITIVE("mutex-name", mutex_name, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
return MUTEX_NAME(mtx);
}
DEFINE_PRIMITIVE("mutex-specific", mutex_specific, subr1, (SCM mtx))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
return MUTEX_SPECIFIC(mtx);
}
DEFINE_PRIMITIVE("mutex-specific-set!", mutex_specific_set, subr2, (SCM mtx, SCM v))
{
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
MUTEX_SPECIFIC(mtx) = v;
return STk_void;
}
DEFINE_PRIMITIVE("mutex-state", mutex_state, subr1, (SCM mtx))
{
SCM res;
if (! MUTEXP(mtx)) error_bad_mutex(mtx);
pthread_mutex_lock(&MUTEX_MYMUTEX(mtx));
if (MUTEX_LOCKED(mtx))
res = (MUTEX_OWNER(mtx) == STk_void) ? sym_not_owned : MUTEX_OWNER(mtx);
else
res = (MUTEX_OWNER(mtx) == STk_void) ? sym_not_abandoned: sym_abandoned;
pthread_mutex_unlock(&MUTEX_MYMUTEX(mtx));
return res;
}
/* ====================================================================== *\
*
* C O N D V A R S
*
\* ====================================================================== */
struct condv_obj {
stk_header header;
SCM name;
SCM specific;
pthread_cond_t mycondv;
};
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_mutex))
#define CONDV_NAME(p) (((struct mutex_obj *) (p))->name)
#define CONDV_SPECIFIC(p) (((struct mutex_obj *) (p))->specific)
#define CONDV_MYCONDV(p) (((struct mutex_obj *) (p))->mycondv)
void error_bad_condv(SCM obj)
{
STk_error("bad confdition variaable ~S", obj);
}
void condv_finalizer(SCM cv)
{
STk_debug("Finalizer condv ~S", cv);
pthread_cond_destroy(&CONDV_MYCONDV(cv));
}
/* ====================================================================== */
DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
{
SCM z;
if (name) {
if (!STRINGP(name))
STk_error("bad condition variable name ~S", name);
}
else name = STk_Cstring2string("");
NEWCELL(z, condv);
CONDV_NAME(z) = name;
CONDV_SPECIFIC(z) = STk_void;
pthread_cond_init(&CONDV_MYCONDV(z), NULL);
STk_register_finalizer(z, condv_finalizer);
return z;
}
DEFINE_PRIMITIVE("condition-variable?", condvp, subr1, (SCM obj))
{
return MAKE_BOOLEAN(CONDVP(obj));
}
DEFINE_PRIMITIVE("condition-variable-name", condv_name, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
return CONDV_NAME(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific", condv_specific, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
return CONDV_SPECIFIC(cv);
}
DEFINE_PRIMITIVE("condition-variable-specific-set!", condv_specific_set, subr2,
(SCM cv, SCM v))
{
if (! CONDVP(cv)) error_bad_condv(cv);
CONDV_SPECIFIC(cv) = v;
return STk_void;
}
DEFINE_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
pthread_cond_signal(&CONDV_MYCONDV(cv));
return STk_void;
}
DEFINE_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv))
{
if (! CONDVP(cv)) error_bad_condv(cv);
pthread_cond_broadcast(&CONDV_MYCONDV(cv));
return STk_void;
}
/* ====================================================================== *\
* Initialization ...
\* ====================================================================== */
static void print_mutex(SCM mutex, SCM port, int mode)
{
char *name = STRING_CHARS(MUTEX_NAME(mutex));
STk_puts("#[mutex ", port);
if (*name)
STk_puts(name, port);
else
STk_fprintf(port, "%lx", (unsigned long) mutex);
STk_putc(']', port);
}
static void print_condv(SCM condv, SCM port, int mode)
{
char *name = STRING_CHARS(CONDV_NAME(condv));
STk_puts("#[condition-variable ", port);
if (*name)
STk_puts(name, port);
else
STk_fprintf(port, "%lx", (unsigned long) condv);
STk_putc(']', port);
}
/* The stucture which describes the mutex type */
static struct extended_type_descr xtype_mutex = {
"mutex", /* name */
print_mutex /* print function */
};
/* The stucture which describes the condv type */
static struct extended_type_descr xtype_condv = {
"condv", /* name */
print_condv /* print function */
};
int STk_init_mutexes(void)
{
/* Define some symbols */
sym_not_owned = STk_intern("not-owned");
sym_abandoned = STk_intern("abandoned");
sym_not_abandoned = STk_intern("not-abandoned");
/* Mutex and condv type declarations */
DEFINE_XTYPE(mutex, &xtype_mutex);
DEFINE_XTYPE(condv, &xtype_condv);
/* Mutexes primitives */
ADD_PRIMITIVE(make_mutex);
ADD_PRIMITIVE(mutexp);
ADD_PRIMITIVE(mutex_name);
ADD_PRIMITIVE(mutex_specific);
ADD_PRIMITIVE(mutex_specific_set);
ADD_PRIMITIVE(mutex_state);
/* Condv primitives */
ADD_PRIMITIVE(make_condv);
ADD_PRIMITIVE(condvp);
ADD_PRIMITIVE(condv_name);
ADD_PRIMITIVE(condv_specific);
ADD_PRIMITIVE(condv_specific_set);
ADD_PRIMITIVE(condv_signal);
ADD_PRIMITIVE(condv_broadcast);
return TRUE;
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 1-Feb-2006 17:12 (eg)
* Last file update: 3-Feb-2006 10:45 (eg)
*/
#ifndef STKLOS_H
......@@ -144,7 +144,8 @@ typedef enum {
tc_subr23, tc_vsubr, tc_apply, tc_vector, tc_uvector, /* 20 */
tc_hash_table, tc_port, tc_frame, tc_next_method, tc_promise, /* 25 */
tc_regexp, tc_process, tc_continuation, tc_values, tc_parameter, /* 30 */
tc_socket, tc_struct_type, tc_struct, tc_thread, /* 35 */
tc_socket, tc_struct_type, tc_struct, tc_thread, tc_mutex, /* 35 */
tc_condv, /* 40 */
tc_last_standard /* must be last as indicated by its name */
} type_cell;
......@@ -1136,7 +1137,7 @@ SCM STk_load_bcode_file(SCM f);
int STk_load_boot(char *s);
int STk_boot_from_C(void);
int STk_init_vm(int stack_size);
int STk_init_vm();
/*****************************************************************************/
......
/*
* threads.c -- Threads support in STklos
* thread.c -- Threads support in STklos
*
* Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg)
* Last file update: 1-Feb-2006 18:07 (eg)
* Last file update: 3-Feb-2006 11:06 (eg)
*/
......@@ -32,7 +32,7 @@
#include "stklos.h"
#include "vm.h"
static SCM primordial, thread_terminated_cond;
static SCM primordial, cond_thread_terminated;
enum thread_state { th_new, th_runnable, th_terminated, th_blocked};
......@@ -44,11 +44,11 @@ struct thread_obj {
SCM specific;
SCM end_result;
SCM end_exception;
SCM mutexes;
SCM dynwind;
enum thread_state state;
vm_thread_t *vm;
pthread_t pthread;
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
};
......@@ -58,11 +58,11 @@ struct thread_obj {
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception)
#define THREAD_MUTEXES(p) (((struct thread_obj *) (p))->mutexes)
#define THREAD_DYNWIND(p) (((struct thread_obj *) (p))->dynwind)
#define THREAD_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
#define THREAD_PTHREAD(p) (((struct thread_obj *) (p))->pthread)
#define THREAD_MYMUTEX(p) (((struct thread_obj *) (p))->mymutex)
#define THREAD_MYCONDV(p) (((struct thread_obj *) (p))->mycondv)
static SCM all_threads = STk_nil;
......@@ -100,6 +100,45 @@ vm_thread_t *STk_get_current_vm(void)
}
/* ====================================================================== */
static void terminate_scheme_thread(void *arg)
{
SCM thr = (SCM) arg;
STk_debug("Cleaning thread thr");
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
THREAD_STATE(thr) = th_terminated;
/* signal the death of this thread to the ones waiting it */
pthread_cond_broadcast(&THREAD_MYCONDV(thr));
pthread_mutex_unlock(&THREAD_MYMUTEX(thr));
}
static void *start_scheme_thread(void *arg)
{
volatile SCM thr = (SCM) arg;
vm_thread_t *vm;
SCM res;
vm = THREAD_VM(thr) = STk_allocate_vm(5000); // FIX:
vm->scheme_thread = thr;
pthread_setspecific(vm_key, vm);
pthread_cleanup_push(terminate_scheme_thread, thr);
res = STk_C_apply(THREAD_THUNK(thr), 0);
if (THREAD_EXCEPTION(thr) == STk_false) {
THREAD_RESULT(thr) = res;
}
pthread_cleanup_pop(1);
return NULL;
}
/* ====================================================================== */
static SCM do_make_thread(SCM thunk, char *name)
......@@ -113,12 +152,10 @@ static SCM do_make_thread(SCM thunk, char *name)
THREAD_SPECIFIC(z) = STk_void;
THREAD_RESULT(z) = STk_void;
THREAD_EXCEPTION(z) = STk_false;
THREAD_MUTEXES(z) = STk_nil;
THREAD_DYNWIND(z) = STk_nil;
THREAD_STATE(z) = th_new;
// FIX: lock
all_threads = STk_cons(z, all_threads); /* For the GC */
// all_threads = STk_cons(z, all_threads); /* For the GC */
return z;
}
......@@ -128,7 +165,7 @@ DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
return vm->scheme_thread;
}
DEFINE_PRIMITIVE("make-thread", make_thread, subr12, (SCM thunk, SCM name))
DEFINE_PRIMITIVE("%make-thread", make_thread, subr12, (SCM thunk, SCM name))
{
SCM z;
......@@ -156,58 +193,74 @@ DEFINE_PRIMITIVE("thread-name", thread_name, subr1, (SCM thr))
return THREAD_NAME(thr);
}
DEFINE_PRIMITIVE("thread-specific", thread_specific, subr1, (SCM thr))
DEFINE_PRIMITIVE("%thread-end-exception", thread_end_exception, subr1, (SCM thr))
{
if (! THREADP(thr)) error_bad_thread(thr);
return THREAD_SPECIFIC(thr);
if (!THREADP(thr)) error_bad_thread(thr);
return THREAD_EXCEPTION(thr);
}
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2,
(SCM thr, SCM value))
DEFINE_PRIMITIVE("%thread-end-exception-set!", thread_end_exception_set,
subr2, (SCM thr, SCM val))
{
if (!THREADP(thr)) error_bad_thread(thr);
THREAD_SPECIFIC(thr) = value;
THREAD_EXCEPTION(thr) = val;
return STk_void;
}
DEFINE_PRIMITIVE("%thread-end-result", thread_end_result, subr1, (SCM thr))
{
if (!THREADP(thr)) error_bad_thread(thr);
return THREAD_RESULT(thr);
}
static void terminate_scheme_thread(SCM thr)
DEFINE_PRIMITIVE("%thread-end-result-set!", thread_end_result_set,
subr2, (SCM thr, SCM val))
{
THREAD_STATE(thr) = th_terminated;
// ...........................
if (!THREADP(thr)) error_bad_thread(thr);
THREAD_RESULT(thr) = val;
return STk_void;
}
DEFINE_PRIMITIVE("thread-specific", thread_specific, subr1, (SCM thr))
{
if (! THREADP(thr)) error_bad_thread(thr);
return THREAD_SPECIFIC(thr);
}
static void * start_scheme_thread(void *arg)
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2,
(SCM thr, SCM value))
{
SCM thr = (SCM) arg;
vm_thread_t *vm;
if (!THREADP(thr)) error_bad_thread(thr);
THREAD_SPECIFIC(thr) = value;
return STk_void;
}
vm = STk_allocate_vm(5000); // FIX:
pthread_setspecific(vm_key, vm);
THREAD_VM(thr) = vm;
vm->scheme_thread = thr;
THREAD_RESULT(thr) = STk_C_apply(THREAD_THUNK(thr), 0);
STk_debug("On termine normallement la thread ~S", thr);
terminate_scheme_thread(thr);
return NULL;
}
DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
{
pthread_attr_t attr;
if (!THREADP(thr)) error_bad_thread(thr);
if (THREAD_STATE(thr) != th_new)
STk_error("thread has already been started ~S", thr);
THREAD_STATE(thr) = th_runnable;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, TRUE);
pthread_mutex_init(&THREAD_MYMUTEX(thr), NULL);
pthread_cond_init(&THREAD_MYCONDV(thr), NULL);
// pthread_mutex_lock(&THREAD_MYMUTEX(thr));
if (pthread_create(&THREAD_PTHREAD(thr), NULL, start_scheme_thread, thr))
STk_error("cannot start thread ~S", thr);
pthread_attr_destroy(&attr);
return thr;
}
......@@ -227,28 +280,55 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
{
if (!THREADP(thr)) error_bad_thread(thr);
if (THREAD_STATE(thr) != th_terminated) {
terminate_scheme_thread(thr);
if (thr == primordial) {
/* Terminate the primordial thread exits the program */
STk_quit(0);
}
THREAD_EXCEPTION(thr) = STk_nil; //FIX:
THREAD_EXCEPTION(thr) = STk_make_C_cond(cond_thread_terminated, 0);
pthread_cancel(THREAD_PTHREAD(thr));
}
return STk_void;
}
DEFINE_PRIMITIVE("all-threads", all_threads, subr0, (void))
DEFINE_PRIMITIVE("%thread-join!", thread_join, subr4, (SCM thr, SCM tm1, SCM tm2,
SCM use_time))
{
/* Use reverse to give a (time creation ordered) copy of our list */
return STk_reverse(all_threads);
struct timespec ts;
int overflow;
time_t t1 = STk_integer2uint32(tm1, &overflow);
long t2 = STk_integer2uint32(tm2, &overflow);
SCM res = STk_false;
if (!THREADP(thr)) error_bad_thread(thr);
ts.tv_sec = t1;
ts.tv_nsec = t2;
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
while (THREAD_STATE(thr) != th_terminated) {
STk_debug("On est dans la boucle avec %d", THREAD_STATE(thr));
if (use_time != STk_false) {
int n = pthread_cond_timedwait(&THREAD_MYCONDV(thr),
&THREAD_MYMUTEX(thr),
&ts);
if (n == ETIMEDOUT) { STk_debug("TIMEOUT"); res = STk_true; break; }
}
else
pthread_cond_wait(&THREAD_MYCONDV(thr), &THREAD_MYMUTEX(thr));
}
pthread_mutex_unlock(&THREAD_MYMUTEX(thr));
STk_debug("Fin de l'attente");
return res;
}
/* ======================================================================
* Initialization ...
* ======================================================================
......@@ -294,8 +374,8 @@ int STk_init_threads(int stack_size)
pthread_setspecific(vm_key, vm);
/* Define the threads exceptions */
// thread_terminated_cond = STk_defcond_type("&thread-terminated", STk_false,
// STk_nil, STk_current_module);
cond_thread_terminated = STk_defcond_type("&thread-terminated", STk_false,
STk_nil, STk_current_module);
/* Wrap the main thread in a thread called "primordial" */
primordial = do_make_thread(STk_false, STk_Cstring2string("primordial"));
......@@ -308,14 +388,17 @@ int STk_init_threads(int stack_size)