Commit c391ba14 authored by eg's avatar eg

Adding mutexes & condv

parent 9c86f251
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
# #
# Author: Erick Gallesio [eg@unice.fr] # Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg) # 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@ CC = @CC@
CFLAGS = @CFLAGS@ CFLAGS = @CFLAGS@
...@@ -19,10 +19,10 @@ DOCDB = DOCDB ...@@ -19,10 +19,10 @@ DOCDB = DOCDB
stklos_SOURCES = boolean.c boot.c char.c cond.c dynload.c env.c error.c \ 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 \ 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 \ proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.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 ### # The STklos library
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
# #
# Author: Erick Gallesio [eg@unice.fr] # Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg) # 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@ SHELL = @SHELL@
srcdir = @srcdir@ srcdir = @srcdir@
...@@ -131,10 +131,10 @@ DOCDB = DOCDB ...@@ -131,10 +131,10 @@ DOCDB = DOCDB
stklos_SOURCES = boolean.c boot.c char.c cond.c dynload.c env.c error.c \ 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 \ 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 \ proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.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 ### # The STklos library
...@@ -181,14 +181,15 @@ am_stklos_OBJECTS = boolean.$(OBJEXT) boot.$(OBJEXT) char.$(OBJEXT) \ ...@@ -181,14 +181,15 @@ am_stklos_OBJECTS = boolean.$(OBJEXT) boot.$(OBJEXT) char.$(OBJEXT) \
cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) error.$(OBJEXT) \ cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) error.$(OBJEXT) \
extend.$(OBJEXT) fport.$(OBJEXT) gnu-getopt.$(OBJEXT) \ extend.$(OBJEXT) fport.$(OBJEXT) gnu-getopt.$(OBJEXT) \
gnu-glob.$(OBJEXT) hash.$(OBJEXT) keyword.$(OBJEXT) \ gnu-glob.$(OBJEXT) hash.$(OBJEXT) keyword.$(OBJEXT) \
lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) number.$(OBJEXT) \ lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) mutex.$(OBJEXT) \
object.$(OBJEXT) parameter.$(OBJEXT) path.$(OBJEXT) \ number.$(OBJEXT) object.$(OBJEXT) parameter.$(OBJEXT) \
port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) process.$(OBJEXT) \ path.$(OBJEXT) port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) \
promise.$(OBJEXT) read.$(OBJEXT) regexp.$(OBJEXT) \ process.$(OBJEXT) promise.$(OBJEXT) read.$(OBJEXT) \
signal.$(OBJEXT) sio.$(OBJEXT) socket.$(OBJEXT) sport.$(OBJEXT) \ regexp.$(OBJEXT) signal.$(OBJEXT) sio.$(OBJEXT) \
stklos.$(OBJEXT) str.$(OBJEXT) struct.$(OBJEXT) \ socket.$(OBJEXT) sport.$(OBJEXT) stklos.$(OBJEXT) str.$(OBJEXT) \
symbol.$(OBJEXT) system.$(OBJEXT) threads.$(OBJEXT) \ struct.$(OBJEXT) symbol.$(OBJEXT) system.$(OBJEXT) \
uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) vport.$(OBJEXT) thread.$(OBJEXT) uvector.$(OBJEXT) vector.$(OBJEXT) \
vm.$(OBJEXT) vport.$(OBJEXT)
stklos_OBJECTS = $(am_stklos_OBJECTS) stklos_OBJECTS = $(am_stklos_OBJECTS)
stklos_DEPENDENCIES = stklos_DEPENDENCIES =
...@@ -207,19 +208,19 @@ am__depfiles_maybe = depfiles ...@@ -207,19 +208,19 @@ am__depfiles_maybe = depfiles
@AMDEP_TRUE@ ./$(DEPDIR)/gnu-glob.Po ./$(DEPDIR)/hash.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/gnu-glob.Po ./$(DEPDIR)/hash.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/keyword.Po ./$(DEPDIR)/lib.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/keyword.Po ./$(DEPDIR)/lib.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/list.Po ./$(DEPDIR)/misc.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/list.Po ./$(DEPDIR)/misc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/number.Po ./$(DEPDIR)/object.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/mutex.Po ./$(DEPDIR)/number.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/parameter.Po ./$(DEPDIR)/path.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/object.Po ./$(DEPDIR)/parameter.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/port.Po ./$(DEPDIR)/print.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/path.Po ./$(DEPDIR)/port.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/proc.Po ./$(DEPDIR)/process.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/print.Po ./$(DEPDIR)/proc.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/promise.Po ./$(DEPDIR)/read.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/process.Po ./$(DEPDIR)/promise.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/regexp.Po ./$(DEPDIR)/signal.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/read.Po ./$(DEPDIR)/regexp.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/sio.Po ./$(DEPDIR)/socket.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/signal.Po ./$(DEPDIR)/sio.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/sport.Po ./$(DEPDIR)/stklos.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/socket.Po ./$(DEPDIR)/sport.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/str.Po ./$(DEPDIR)/struct.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/stklos.Po ./$(DEPDIR)/str.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/symbol.Po ./$(DEPDIR)/system.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/struct.Po ./$(DEPDIR)/symbol.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/threads.Po ./$(DEPDIR)/uvector.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/system.Po ./$(DEPDIR)/thread.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/vector.Po ./$(DEPDIR)/vm.Po \ @AMDEP_TRUE@ ./$(DEPDIR)/uvector.Po ./$(DEPDIR)/vector.Po \
@AMDEP_TRUE@ ./$(DEPDIR)/vport.Po @AMDEP_TRUE@ ./$(DEPDIR)/vm.Po ./$(DEPDIR)/vport.Po
COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
$(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
CCLD = $(CC) CCLD = $(CC)
...@@ -310,6 +311,7 @@ distclean-compile: ...@@ -310,6 +311,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/lib.Po@am__quote@ @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)/list.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/misc.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)/number.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/object.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@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/parameter.Po@am__quote@
...@@ -330,7 +332,7 @@ distclean-compile: ...@@ -330,7 +332,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/struct.Po@am__quote@ @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)/symbol.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/system.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)/uvector.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/vector.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@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/vm.Po@am__quote@
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
* *
* Author: Erick Gallesio [eg@unice.fr] * Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg) * 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) ...@@ -74,8 +74,9 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_boolean() && STk_init_boolean() &&
STk_init_reader() && STk_init_reader() &&
STk_init_system() && STk_init_system() &&
STk_init_vm(stack_size) && //FIX: Ne sert pas STk_init_vm() &&
STk_init_threads(stack_size)&& STk_init_threads(stack_size)&&
STk_init_mutexes() &&
STk_init_hash() && STk_init_hash() &&
STk_init_misc() && STk_init_misc() &&
STk_init_signal() && 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 @@ ...@@ -21,7 +21,7 @@
* *
* Author: Erick Gallesio [eg@unice.fr] * Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg) * 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 #ifndef STKLOS_H
...@@ -144,7 +144,8 @@ typedef enum { ...@@ -144,7 +144,8 @@ typedef enum {
tc_subr23, tc_vsubr, tc_apply, tc_vector, tc_uvector, /* 20 */ 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_hash_table, tc_port, tc_frame, tc_next_method, tc_promise, /* 25 */
tc_regexp, tc_process, tc_continuation, tc_values, tc_parameter, /* 30 */ 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 */ tc_last_standard /* must be last as indicated by its name */
} type_cell; } type_cell;
...@@ -1136,7 +1137,7 @@ SCM STk_load_bcode_file(SCM f); ...@@ -1136,7 +1137,7 @@ SCM STk_load_bcode_file(SCM f);
int STk_load_boot(char *s); int STk_load_boot(char *s);
int STk_boot_from_C(void); 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> * Copyright 2006 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
* *
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
* *
* Author: Erick Gallesio [eg@essi.fr] * Author: Erick Gallesio [eg@essi.fr]
* Creation date: 23-Jan-2006 12:14 (eg) * 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 @@ ...@@ -32,7 +32,7 @@
#include "stklos.h" #include "stklos.h"
#include "vm.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}; enum thread_state { th_new, th_runnable, th_terminated, th_blocked};
...@@ -44,11 +44,11 @@ struct thread_obj { ...@@ -44,11 +44,11 @@ struct thread_obj {
SCM specific; SCM specific;
SCM end_result; SCM end_result;
SCM end_exception; SCM end_exception;
SCM mutexes;
SCM dynwind;
enum thread_state state; enum thread_state state;
vm_thread_t *vm; vm_thread_t *vm;
pthread_t pthread; pthread_t pthread;
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
}; };
...@@ -58,11 +58,11 @@ struct thread_obj { ...@@ -58,11 +58,11 @@ struct thread_obj {
#define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific) #define THREAD_SPECIFIC(p) (((struct thread_obj *) (p))->specific)
#define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result) #define THREAD_RESULT(p) (((struct thread_obj *) (p))->end_result)
#define THREAD_EXCEPTION(p) (((struct thread_obj *) (p))->end_exception) #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_STATE(p) (((struct thread_obj *) (p))->state)
#define THREAD_VM(p) (((struct thread_obj *) (p))->vm) #define THREAD_VM(p) (((struct thread_obj *) (p))->vm)
#define THREAD_PTHREAD(p) (((struct thread_obj *) (p))->pthread) #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; static SCM all_threads = STk_nil;
...@@ -100,6 +100,45 @@ vm_thread_t *STk_get_current_vm(void) ...@@ -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) static SCM do_make_thread(SCM thunk, char *name)
...@@ -113,12 +152,10 @@ 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_SPECIFIC(z) = STk_void;
THREAD_RESULT(z) = STk_void; THREAD_RESULT(z) = STk_void;
THREAD_EXCEPTION(z) = STk_false; THREAD_EXCEPTION(z) = STk_false;
THREAD_MUTEXES(z) = STk_nil;
THREAD_DYNWIND(z) = STk_nil;
THREAD_STATE(z) = th_new; THREAD_STATE(z) = th_new;
// FIX: lock // FIX: lock
all_threads = STk_cons(z, all_threads); /* For the GC */ // all_threads = STk_cons(z, all_threads); /* For the GC */
return z; return z;
} }
...@@ -128,7 +165,7 @@ DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void)) ...@@ -128,7 +165,7 @@ DEFINE_PRIMITIVE("current-thread", current_thread, subr0, (void))
return vm->scheme_thread; 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; SCM z;
...@@ -156,58 +193,74 @@ DEFINE_PRIMITIVE("thread-name", thread_name, subr1, (SCM thr)) ...@@ -156,58 +193,74 @@ DEFINE_PRIMITIVE("thread-name", thread_name, subr1, (SCM thr))
return THREAD_NAME(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); if (!THREADP(thr)) error_bad_thread(thr);
return THREAD_SPECIFIC(thr); return THREAD_EXCEPTION(thr);
} }
DEFINE_PRIMITIVE("thread-specific-set!", thread_specific_set, subr2, DEFINE_PRIMITIVE("%thread-end-exception-set!", thread_end_exception_set,
(SCM thr, SCM value)) subr2, (SCM thr, SCM val))
{ {
if (!THREADP(thr)) error_bad_thread(thr); if (!THREADP(thr)) error_bad_thread(thr);
THREAD_SPECIFIC(thr) = value; THREAD_EXCEPTION(thr) = val;
return STk_void; 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; if (!THREADP(thr)) error_bad_thread(thr);
vm_thread_t *vm; THREAD_SPECIFIC(thr) = value;
return STk_void;
}
vm = STk_allocate_vm(5000); // FIX:
pthread_setspecific(vm_key, vm);
THREAD_VM(thr) = vm;