diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm index 80cf6566..d917cf25 100644 --- a/lib/srfi/18/interface.scm +++ b/lib/srfi/18/interface.scm @@ -14,3 +14,18 @@ (if (%thread-terminate! thread) ;; need to yield if terminating ourself (thread-yield!))) +(define (thread-sleep! timeout) + (%thread-sleep! timeout) + (thread-yield!)) + +(define (mutex-lock! mutex . o) + (let ((timeout (and (pair? o) (car o))) + (thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t))) + (if (not (%mutex-lock! mutex timeout thread)) + (thread-yield!)))) + +(define (mutex-unlock! mutex . o) + #f) + +(define current-time get-time-of-day) +(define time? timeval?) diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index d606784a..24c57050 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -9,7 +9,7 @@ #define sexp_mutex_name(x) sexp_slot_ref(x, 0) #define sexp_mutex_specific(x) sexp_slot_ref(x, 1) #define sexp_mutex_thread(x) sexp_slot_ref(x, 2) -#define sexp_mutex_lock(x) sexp_slot_ref(x, 3) +#define sexp_mutex_lockp(x) sexp_slot_ref(x, 3) #define sexp_condvar_name(x) sexp_slot_ref(x, 0) #define sexp_condvar_specific(x) sexp_slot_ref(x, 1) @@ -20,6 +20,8 @@ /* static int mutex_id, condvar_id; */ +/**************************** threads *************************************/ + static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) { sexp_gc_var2(name, op); sexp_gc_preserve2(ctx, name, op); @@ -108,7 +110,7 @@ sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) { return sexp_make_boolean(ctx == thread); } -void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { +static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #if SEXP_USE_FLONUMS double d; #endif @@ -149,6 +151,68 @@ sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp time return SEXP_FALSE; } +sexp sexp_thread_sleep (sexp ctx sexp_api_params(self, n), sexp timeout) { + sexp_assert_type(ctx, sexp_numberp, SEXP_NUMBER, timeout); + sexp_context_waitp(ctx) = 1; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; +} + +/**************************** mutexes *************************************/ + +sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { + /* sexp_assert_type(ctx, sexp_mutexp, mutex_id, timeout); */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + if (sexp_contextp(sexp_mutex_thread(mutex))) + return sexp_mutex_thread(mutex); + else + return sexp_intern(ctx, "not-owned", -1); + } else { + return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); + } +} + +sexp sexp_mutex_lock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp timeout, sexp thread) { + if (thread == SEXP_TRUE) + thread = ctx; + if (sexp_not(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_TRUE; + sexp_mutex_thread(mutex) = thread; + return SEXP_TRUE; + } else { + sexp_context_waitp(ctx) = 1; + sexp_context_event(ctx) = mutex; + sexp_insert_timed(ctx, ctx, timeout); + return SEXP_FALSE; + } +} + +sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) { + if (sexp_not(condvar)) { + /* normal unlock */ + if (sexp_truep(sexp_mutex_lockp(mutex))) { + sexp_mutex_lockp(mutex) = SEXP_FALSE; + sexp_mutex_thread(mutex) = ctx; + /* XXXX search for threads blocked on this mutex */ + } + } else { + /* wait on condition var */ + + } +} + +/**************************** condition variables *************************/ + +sexp sexp_condition_variable_signal (sexp ctx sexp_api_params(self, n), sexp condvar) { + return SEXP_VOID; +} + +sexp sexp_condition_variable_broadcast (sexp ctx sexp_api_params(self, n), sexp condvar) { + return SEXP_VOID; +} + +/**************************** the scheduler *******************************/ + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); @@ -223,6 +287,8 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { return res; } +/**************************************************************************/ + sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT); @@ -232,9 +298,15 @@ sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) { sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start); sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate); sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join); + sexp_define_foreign(ctx, env, "%thread-sleep!", 1, sexp_thread_sleep); sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name); sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific); sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set); + sexp_define_foreign(ctx, env, "mutex-state", 1, sexp_mutex_state); + sexp_define_foreign(ctx, env, "%mutex-lock!", 3, sexp_mutex_lock); + sexp_define_foreign(ctx, env, "%mutex-unlock!", 3, sexp_mutex_unlock); + sexp_define_foreign(ctx, env, "condition-variable-signal!", 1, sexp_condition_variable_signal); + sexp_define_foreign(ctx, env, "condition-variable-broadcast!", 1, sexp_condition_variable_broadcast); sexp_global(ctx, SEXP_G_THREADS_SCHEDULER) = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE); diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm index 611c0670..093c97a7 100644 --- a/lib/srfi/18/types.scm +++ b/lib/srfi/18/types.scm @@ -19,3 +19,6 @@ (name condition-variable-name) (specific condition-variable-specific condition-variable-specific-set!) (threads %condition-variable-threads %condition-variable-threads-set!)) + +(define (make-condition-variable . o) + (%make-condition-variable (and (pair? o) (car o)) #f #f))