Commit 195a9467 authored by separdau's avatar separdau

src/error.c: added a function to create an error like STk_error but without

 raising it (it returns it). There is a lot of code duplication but I didn't
 know how to use it from STk_error because of the ... argument.
all threads: renamed _specific to sys_ (sys_thread, sys_mutex, sys_condv)
 for code and data which are specific to a thread system. The _specific was
 confusing with TLS specific.
all lurc thread: deal in the best way possible with lurc errors.
parent 5ce18a3c
/*
This file was automatically generated on Thu Apr 20 15:52:58 2006 by make-C-boot
This is a dump of the image in file /home/stephane/src/stklos-0.73-hg/lib/boot.img3
This file was automatically generated on Fri Apr 21 14:13:36 2006 by make-C-boot
This is a dump of the image in file /home/separdau/src/stklos-0.73-hg/lib/boot.img3
***DO NOT EDIT BY HAND***
*/
......
......@@ -141,6 +141,31 @@ SCM STk_format_error(char *format, ...)
}
SCM STk_make_error(char *format, ...)
{
va_list ap;
SCM out, bt;
/* Grab a baktrace */
bt = STk_vm_bt();
/* Open a string port */
out = STk_open_output_string();
/* Build the message string in the string port */
va_start(ap, format);
print_format(out, format, ap);
va_end(ap);
/* and return error */
return STk_make_C_cond(STk_err_mess_condition,
3,
STk_false, /* no location */
bt,
STk_get_output_string(out));
}
void STk_error(char *format, ...)
{
va_list ap;
......@@ -167,7 +192,6 @@ void STk_error(char *format, ...)
}
void STk_warning(char *format, ...)
{
va_list ap;
......
......@@ -65,7 +65,7 @@ DEFINE_PRIMITIVE("make-mutex", make_mutex, subr01, (SCM name))
MUTEX_OWNER(z) = STk_false;
MUTEX_LOCKED(z) = FALSE;
STk_make_mutex_specific(z);
STk_make_sys_mutex(z);
return z;
}
......@@ -116,7 +116,7 @@ DEFINE_PRIMITIVE("make-condition-variable", make_condv, subr01, (SCM name))
CONDV_NAME(z) = (name ? name : STk_false);
CONDV_SPECIFIC(z) = STk_void;
STk_make_condv_specific(z);
STk_make_sys_condv(z);
return z;
}
......
......@@ -50,7 +50,7 @@ struct mutex_obj {
SCM specific;
SCM owner;
int locked;
struct mutex_obj_specific sys_mutex;
struct sys_mutex_obj sys_mutex;
};
#define MUTEXP(p) (BOXED_TYPE_EQ((p), tc_mutex))
......@@ -69,7 +69,7 @@ struct condv_obj {
stk_header header;
SCM name;
SCM specific;
struct condv_obj_specific sys_condv;
struct sys_condv_obj sys_condv;
};
#define CONDVP(p) (BOXED_TYPE_EQ((p), tc_condv))
......
......@@ -50,7 +50,7 @@ static void mutex_finalizer(SCM mtx)
}
void STk_make_mutex_specific(SCM z)
void STk_make_sys_mutex(SCM z)
{
lurc_mutex_init(&MUTEX_MYMUTEX(z), NULL);
lurc_signal_init(&MUTEX_MYSIGNAL(z), NULL);
......@@ -208,7 +208,7 @@ static void condv_finalizer(SCM cv)
lurc_signal_destroy(&CONDV_MYSIGNAL(cv));
}
void STk_make_condv_specific(SCM z)
void STk_make_sys_condv(SCM z)
{
CONDV_TARGET(z) = CV_NONE;
CONDV_EMITTED(z) = -1;
......
......@@ -40,7 +40,7 @@
*
\* ====================================================================== */
struct mutex_obj_specific {
struct sys_mutex_obj {
lurc_mutex_t mymutex;
lurc_signal_t mysignal;
};
......@@ -56,7 +56,7 @@ struct mutex_obj_specific {
typedef enum {CV_NONE, CV_ONE, CV_ALL} cv_target_t;
struct condv_obj_specific {
struct sys_condv_obj {
lurc_signal_t mysignal;
cv_target_t target;
lurc_instant_t emitted;
......@@ -74,8 +74,8 @@ EXTERN_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
EXTERN_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv));
EXTERN_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv));
extern void STk_make_condv_specific(SCM z);
extern void STk_make_mutex_specific(SCM z);
extern void STk_make_sys_condv(SCM z);
extern void STk_make_sys_mutex(SCM z);
#endif /* ! _STK_MUTEX_LURC_H */
......@@ -43,7 +43,7 @@ static void mutex_finalizer(SCM mtx)
pthread_cond_destroy(&MUTEX_MYCONDV(mtx));
}
void STk_make_mutex_specific(SCM z)
void STk_make_sys_mutex(SCM z)
{
pthread_mutex_init(&MUTEX_MYMUTEX(z), NULL);
pthread_cond_init(&MUTEX_MYCONDV(z), NULL);
......@@ -174,7 +174,7 @@ static void condv_finalizer(SCM cv)
pthread_cond_destroy(&CONDV_MYCONDV(cv));
}
void STk_make_condv_specific(SCM z)
void STk_make_sys_condv(SCM z)
{
pthread_cond_init(&CONDV_MYCONDV(z), NULL);
......
......@@ -35,7 +35,7 @@
*
\* ====================================================================== */
struct mutex_obj_specific {
struct sys_mutex_obj {
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
};
......@@ -49,7 +49,7 @@ struct mutex_obj_specific {
*
\* ====================================================================== */
struct condv_obj_specific {
struct sys_condv_obj {
pthread_cond_t mycondv;
};
......@@ -63,8 +63,8 @@ EXTERN_PRIMITIVE("%mutex-unlock!", mutex_unlock, subr3, (SCM mtx, SCM cv, SCM tm
EXTERN_PRIMITIVE("condition-variable-signal!", condv_signal, subr1, (SCM cv));
EXTERN_PRIMITIVE("condition-variable-brodcast!", condv_broadcast, subr1, (SCM cv));
extern void STk_make_condv_specific(SCM z);
extern void STk_make_mutex_specific(SCM z);
extern void STk_make_sys_condv(SCM z);
extern void STk_make_sys_mutex(SCM z);
#endif /* ! _STK_MUTEX_PTHREADS_H */
......@@ -347,7 +347,8 @@ SCM STk_load_object_file(SCM f, char *fname);
void STk_signal_error(SCM who, SCM str);
void STk_error(char *format, ...);
SCM STk_format_error(char *format, ...);
SCM STk_make_error(char *format, ...);
SCM STk_format_error(char *format, ...);
void STk_warning(char *format, ...);
void STk_panic(char *format, ...);
void STk_signal(char *str);
......
......@@ -152,7 +152,7 @@ DEFINE_PRIMITIVE("thread-start!", thread_start, subr1, (SCM thr))
THREAD_VM(thr) = new;
THREAD_STATE(thr) = th_runnable;
STk_thread_start_specific(thr);
STk_sys_thread_start(thr);
return thr;
}
......@@ -205,7 +205,7 @@ int STk_init_threads(int stack_size)
DEFINE_XTYPE(thread, &xtype_thread);
/* Specific thread initialisation */
if(STk_init_threads_specific(vm) != TRUE)
if(STk_init_sys_threads(vm) != TRUE)
return FALSE;
/* Define the threads exceptions */
......
......@@ -49,7 +49,7 @@ struct thread_obj {
SCM end_exception;
enum thread_state state;
vm_thread_t *vm;
struct thread_obj_specific sys_thread;
struct sys_thread_obj sys_thread;
};
......
......@@ -39,64 +39,120 @@
#include "vm.h"
#include "thread-common.h"
static void no_vm_error(void){
STk_error("No VM");
}
static void lurc_error(int err){
STk_error("Lurc error: ~S", lurc_strerror(err));
}
/*
* Thread specific value (the VM)
*/
vm_thread_t *STk_get_current_vm(void)
{
return (vm_thread_t *) lurc_get_data();
vm_thread_t *vm = (vm_thread_t *) lurc_get_data();
if(vm == NULL)
no_vm_error();
return vm;
}
/* ====================================================================== */
static void thread_watch(void *arg){
SCM thr = (SCM) arg;
// run the thread thunk
SCM res = STk_C_apply(THREAD_THUNK(thr), 0);
// only catch the result if we did not get out of apply via an exception
if (THREAD_EXCEPTION(thr) == STk_false) {
THREAD_RESULT(thr) = res;
}
}
// this is the lurc thread entry function
static void start_scheme_thread(void *arg)
{
volatile SCM thr = (SCM) arg;
SCM res;
SCM thr = (SCM) arg;
int err;
lurc_set_data(THREAD_VM(thr), NULL);
// we do the VM loop until we're terminated
LURC_WATCH(&THREAD_TERM_SIG(thr)){
res = STk_C_apply(THREAD_THUNK(thr), 0);
if (THREAD_EXCEPTION(thr) == STk_false) {
THREAD_RESULT(thr) = res;
}
if((err = lurc_watch(&THREAD_TERM_SIG(thr), &thread_watch, thr)) != 0){
// this one is tricky we cannot raise, so we save it in the thread
THREAD_EXCEPTION(thr) = STk_make_error("Lurc error: ~S",
lurc_strerror(err));
}
THREAD_STATE(thr) = th_terminated;
// signal the death of this thread
lurc_signal_emit(&THREAD_DEATH_SIG(thr));
if((err = lurc_signal_emit(&THREAD_DEATH_SIG(thr))) != 0){
// we cannot notify any waiting threads that we have a problem,
// this is a real panic since there's no way to forward the error.
STk_panic("Lurc error: ~S", lurc_strerror(err));
}
// FIXME: abandon the mutexes ?
// now deallocate the signals
lurc_signal_destroy(&THREAD_TERM_SIG(thr));
lurc_signal_destroy(&THREAD_DEATH_SIG(thr));
if(((err = lurc_signal_destroy(&THREAD_TERM_SIG(thr))) != 0)
|| ((err = lurc_signal_destroy(&THREAD_DEATH_SIG(thr))) != 0)){
// any error here is fatal since we cannot raise it properly
STk_panic("Lurc error: ~S", lurc_strerror(err));
}
STk_thread_terminate_common(thr);
}
/* ====================================================================== */
void STk_thread_start_specific(SCM thr)
void STk_sys_thread_start(SCM thr)
{
lurc_signal_attr_t attr;
int err;
// give them semi-meaningful names
THREAD_TERM_SIG(thr) = lurc_signal("thread-term-sig");
THREAD_DEATH_SIG(thr) = lurc_signal("thread-death-sig");
if((err = lurc_signal_attr_init(&attr)) != 0)
lurc_error(err);
// first signal
if((err = lurc_signal_attr_setname(&attr, "thread-term-sig")) != 0
|| (err = lurc_signal_init(&(THREAD_TERM_SIG(thr)), &attr)) != 0){
lurc_signal_attr_destroy(&attr);
lurc_error(err);
}
// second signal
if((err = lurc_signal_attr_setname(&attr, "thread-death-sig")) != 0
|| (err = lurc_signal_init(&(THREAD_DEATH_SIG(thr)), &attr)) != 0){
lurc_signal_attr_destroy(&attr);
// do not forget the first successfull signal
lurc_signal_destroy(&(THREAD_TERM_SIG(thr)));
lurc_error(err);
}
// cleanup
if((err = lurc_signal_attr_destroy(&attr)) != 0){
// do not forget the signals
lurc_signal_destroy(&(THREAD_TERM_SIG(thr)));
lurc_signal_destroy(&(THREAD_DEATH_SIG(thr)));
lurc_error(err);
}
if (lurc_thread_create(&THREAD_LTHREAD(thr), NULL,
&start_scheme_thread, thr))
STk_error("cannot start thread ~S", thr);
if((err = lurc_thread_create(&THREAD_LTHREAD(thr), NULL,
&start_scheme_thread, thr)) != 0){
// do not forget the signals
lurc_signal_destroy(&(THREAD_TERM_SIG(thr)));
lurc_signal_destroy(&(THREAD_DEATH_SIG(thr)));
lurc_error(err);
}
}
DEFINE_PRIMITIVE("thread-yield!", thread_yield, subr0, (void))
{
lurc_pause();
int err;
if((err = lurc_pause()) != 0)
lurc_error(err);
return STk_void;
}
......@@ -105,9 +161,10 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
if (!THREADP(thr)) error_bad_thread(thr);
if (THREAD_STATE(thr) != th_terminated) {
int err;
// emit its term signal
lurc_signal_emit(&THREAD_TERM_SIG(thr));
if((err = lurc_signal_emit(&THREAD_TERM_SIG(thr))) != 0)
lurc_error(err);
if (THREAD_EXCEPTION(thr) == STk_void) {
/* Be sure to register the first canceller only! */
THREAD_EXCEPTION(thr) =
......@@ -115,7 +172,11 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
}
/* wait for it to terminate (also works for self) */
lurc_signal_await(&THREAD_DEATH_SIG(thr));
if((err = lurc_signal_await(&THREAD_DEATH_SIG(thr))) != 0){
// if we cannot terminate ourselves, we can still notify
// if we cannot terminate someone else, we can notify
lurc_error(err);
}
}
return STk_void;
}
......@@ -137,6 +198,34 @@ lthr_abs_time_to_rel_time(double abs_secs){
return rel_tv;
}
struct prot_wait_t {
lurc_signal_t sig;
SCM thr;
SCM res;
};
static void join_watched_await(void *arg){
struct prot_wait_t *pw = (struct prot_wait_t *)arg;
int err;
if((err = lurc_signal_await(&THREAD_DEATH_SIG(pw->thr))) != 0)
lurc_error(err);
pw->res = STk_false;
}
static void join_protected_await(void *arg){
struct prot_wait_t *pw = (struct prot_wait_t *)arg;
int err;
if((err = lurc_watch(&(pw->sig), &join_watched_await, arg)) != 0)
lurc_error(err);
}
static void join_finally_destroyer(void *arg){
struct prot_wait_t *pw = (struct prot_wait_t *)arg;
int err;
if((err = lurc_signal_destroy(&(pw->sig))) != 0)
lurc_error(err);
}
DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
{
SCM res = STk_true;
......@@ -152,17 +241,28 @@ DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
if(THREAD_STATE(thr) != th_terminated){
if(tm != STk_false){
lurc_signal_t sig_to = lurc_timeout_signal(NULL, rel_tv);
struct prot_wait_t pw;
int err;
if(sig_to == NULL)
STk_error("Lurc cannot allocate signal");
// await its death signal, but no longer than given timeout
LURC_PROTECT{
LURC_WATCH(&sig_to){
lurc_signal_await(&THREAD_DEATH_SIG(thr));
res = STk_false;
}
}LURC_WITH{
pw.thr = thr;
pw.res = STk_true;
pw.sig = sig_to;
if((err = lurc_protect_with(&join_protected_await, &pw,
&join_finally_destroyer, &pw)) != 0){
// try to destroy the signal first
lurc_signal_destroy(&sig_to);
}LURC_PROTECT_END;
}else{ // just a wait
lurc_signal_await(&THREAD_DEATH_SIG(thr));
lurc_error(err);
}
// take the result
res = pw.res;
}else{
int err;
// just a wait
if((err = lurc_signal_await(&THREAD_DEATH_SIG(thr))) != 0)
lurc_error(err);
res = STk_false;
}
}else
......@@ -170,6 +270,20 @@ DEFINE_PRIMITIVE("%thread-join!", thread_join, subr2, (SCM thr, SCM tm))
return res;
}
static void sleep_protected_await(void *arg){
lurc_signal_t *sig = (lurc_signal_t *)arg;
int err;
if((err = lurc_signal_await(sig)) != 0)
lurc_error(err);
}
static void sleep_finally_destroyer(void *arg){
lurc_signal_t *sig = (lurc_signal_t *)arg;
int err;
if((err = lurc_signal_destroy(sig)) != 0)
lurc_error(err);
}
DEFINE_PRIMITIVE("%thread-sleep!", thread_sleep, subr1, (SCM tm))
{
struct timeval rel_tv;
......@@ -181,13 +295,17 @@ DEFINE_PRIMITIVE("%thread-sleep!", thread_sleep, subr1, (SCM tm))
// do the sleep only if > 0
if(rel_tv.tv_sec != 0 || rel_tv.tv_usec != 0){
int err;
lurc_signal_t sig_to = lurc_timeout_signal(NULL, rel_tv);
if(sig_to == NULL)
STk_error("Lurc cannot allocate signal");
// await the given timeout
LURC_PROTECT{
lurc_signal_await(&sig_to);
}LURC_WITH{
if((err = lurc_protect_with(&sleep_protected_await, &sig_to,
&sleep_finally_destroyer, &sig_to)) != 0){
// try to destroy the signal first
lurc_signal_destroy(&sig_to);
}LURC_PROTECT_END;
lurc_error(err);
}
}
return STk_void;
}
......@@ -203,10 +321,11 @@ DEFINE_PRIMITIVE("%thread-system", thread_system, subr0, (void))
* ======================================================================
*/
int STk_init_threads_specific(vm_thread_t *vm)
int STk_init_sys_threads(vm_thread_t *vm)
{
/* Define the key to access the thead specific VM */
lurc_set_data(vm, NULL);
if(lurc_set_data(vm, NULL) != 0)
return FALSE;
return TRUE;
}
......
......@@ -28,7 +28,7 @@
#include <lurc.h>
struct thread_obj_specific {
struct sys_thread_obj {
lurc_thread_t lthread;
lurc_signal_t term_sig; // emit to terminate this thread
lurc_signal_t death_sig; // emitted on thread death
......@@ -41,8 +41,8 @@ struct thread_obj_specific {
extern struct timeval lthr_abs_time_to_rel_time(double abs_secs);
extern void STk_thread_start_specific(SCM thr);
extern int STk_init_threads_specific(vm_thread_t *vm);
extern void STk_sys_thread_start(SCM thr);
extern int STk_init_sys_threads(vm_thread_t *vm);
EXTERN_PRIMITIVE("thread-yield!", thread_yield, subr0, (void));
EXTERN_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr));
......
......@@ -103,7 +103,7 @@ static void *start_scheme_thread(void *arg)
/* ====================================================================== */
void STk_thread_start_specific(SCM thr)
void STk_sys_thread_start(SCM thr)
{
pthread_attr_t attr;
......@@ -145,6 +145,7 @@ DEFINE_PRIMITIVE("thread-terminate!", thread_terminate, subr1, (SCM thr))
pthread_mutex_lock(&THREAD_MYMUTEX(thr));
/* Terminate effectively the thread */
// FIXME: this looks like an error
if (thr == THREAD_VM(thr)->scheme_thread)
pthread_exit(0); /* Suicide */
else
......@@ -212,7 +213,7 @@ DEFINE_PRIMITIVE("%thread-system", thread_system, subr0, (void))
* ======================================================================
*/
int STk_init_threads_specific(vm_thread_t *vm)
int STk_init_sys_threads(vm_thread_t *vm)
{
/* Define the key to access the thead specific VM */
initialize_vm_key();
......
......@@ -28,7 +28,7 @@
#include <pthread.h>
struct thread_obj_specific {
struct sys_thread_obj {
pthread_t pthread;
pthread_mutex_t mymutex;
pthread_cond_t mycondv;
......@@ -39,7 +39,7 @@ struct thread_obj_specific {
#define THREAD_MYMUTEX(p) (((struct thread_obj *) (p))->sys_thread.mymutex)
#define THREAD_MYCONDV(p) (((struct thread_obj *) (p))->sys_thread.mycondv)
extern void STk_thread_start_specific(SCM thr);
extern int STk_init_threads_specific(vm_thread_t *vm);
extern void STk_sys_thread_start(SCM thr);
extern int STk_init_sys_threads(vm_thread_t *vm);
#endif /* ! _STK_THREAD_PTHREADS_H */
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment