diff --git a/libguile/eq.c b/libguile/eq.c index 059954620..813c86563 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -388,6 +388,9 @@ scm_equal_p (SCM x, SCM y) { case scm_tc16_charset: return scm_from_bool (scm_i_char_sets_equal (x, y)); + case scm_tc16_condition_variable: + case scm_tc16_mutex: + return SCM_BOOL_F; default: abort (); } diff --git a/libguile/goops.c b/libguile/goops.c index 4a4fbad99..b07180f39 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -139,6 +139,8 @@ static SCM class_finalizer; static SCM class_ephemeron; static SCM class_ephemeron_table; static SCM class_character_set; +static SCM class_condition_variable; +static SCM class_mutex; static struct scm_ephemeron_table *vtable_class_map; static SCM pre_goops_vtables = SCM_EOL; @@ -345,6 +347,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, { case scm_tc16_charset: return class_character_set; + case scm_tc16_condition_variable: + return class_condition_variable; + case scm_tc16_mutex: + return class_mutex; default: abort (); } @@ -980,6 +986,8 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_ephemeron = scm_variable_ref (scm_c_lookup ("")); class_ephemeron_table = scm_variable_ref (scm_c_lookup ("")); class_character_set = scm_variable_ref (scm_c_lookup ("")); + class_condition_variable = scm_variable_ref (scm_c_lookup ("")); + class_mutex = scm_variable_ref (scm_c_lookup ("")); create_smob_classes (); create_struct_classes (); diff --git a/libguile/print.c b/libguile/print.c index 1ab762058..40d35adb6 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -792,6 +792,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc16_charset: scm_i_print_char_set (exp, port, pstate); break; + case scm_tc16_condition_variable: + scm_i_print_condition_variable (exp, port, pstate); + break; + case scm_tc16_mutex: + scm_i_print_mutex (exp, port, pstate); + break; default: abort (); } diff --git a/libguile/scm.h b/libguile/scm.h index 0ef18a139..1b3533a6d 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -509,6 +509,19 @@ typedef uintptr_t scm_t_bits; /* Objects with scm_tc7_ext. */ #define scm_tc16_charset 0x007f +#define scm_tc16_condition_variable 0x017f +#define scm_tc16_mutex 0x027f +/* +#define scm_tc16_continuation 0x067f +#define scm_tc16_directory 0x077f +#define scm_tc16_hook 0x097f +#define scm_tc16_macro 0x0a7f +#define scm_tc16_malloc 0x0b7f +#define scm_tc16_port_with_print_state 0x0d7f +#define scm_tc16_promise 0x0e7f +#define scm_tc16_random_state 0x0f7f +#define scm_tc16_regexp 0x107f +*/ /* Definitions for tc16: */ #define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x)) diff --git a/libguile/threads.c b/libguile/threads.c index 5780a9481..0f9fae929 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -72,6 +72,15 @@ #include "threads.h" + + +#define SCM_MUTEXP(x) SCM_HAS_TYP16 (x, scm_tc16_mutex) +#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condition_variable, x) +#define SCM_VALIDATE_CONDVAR(_pos, _obj) \ + SCM_ASSERT_TYPE (SCM_CONDVARP (_obj), (_obj), (_pos), FUNC_NAME, "condvar") +#define SCM_VALIDATE_MUTEX(_pos, _obj) \ + SCM_ASSERT_TYPE (SCM_MUTEXP (_obj), (_obj), (_pos), FUNC_NAME, "mutex") + #if 0 @@ -952,7 +961,7 @@ enum scm_mutex_kind { }; struct scm_mutex { - scm_i_pthread_mutex_t lock; + scm_t_bits tag_and_flags; /* The thread that owns this mutex, or #f if the mutex is unlocked. */ SCM owner; /* Queue of threads waiting for this mutex. */ @@ -960,16 +969,32 @@ struct scm_mutex { /* For SCM_MUTEX_RECURSIVE (and only SCM_MUTEX_RECURSIVE), the recursive lock count. The first lock does not count. */ int level; + scm_i_pthread_mutex_t lock; }; -#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((struct scm_mutex *) SCM_SMOB_DATA (x)) -#define SCM_MUTEX_KIND(x) ((enum scm_mutex_kind) (SCM_SMOB_FLAGS (x) & 0x3)) - -static int -scm_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) +static struct scm_mutex* +scm_to_mutex (SCM x) { - struct scm_mutex *m = SCM_MUTEX_DATA (mx); + if (!SCM_MUTEXP (x)) abort (); + return (struct scm_mutex*) SCM_UNPACK_POINTER (x); +} + +static SCM +scm_from_mutex (struct scm_mutex *m) +{ + return SCM_PACK_POINTER (m); +} + +static enum scm_mutex_kind +mutex_kind (struct scm_mutex *m) +{ + return m->tag_and_flags >> 16; +} + +int +scm_i_print_mutex (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + struct scm_mutex *m = scm_to_mutex (mx); scm_puts ("#", port); @@ -1003,14 +1028,15 @@ SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, } m = scm_gc_malloc (sizeof (struct scm_mutex), "mutex"); + m->tag_and_flags = scm_tc16_mutex | (mkind << 16); + m->owner = SCM_BOOL_F; + m->waiting = make_queue (); + m->level = 0; /* Because PTHREAD_MUTEX_INITIALIZER is static, it's plain old data, and so we can just copy it. */ memcpy (&m->lock, &lock, sizeof (m->lock)); - m->owner = SCM_BOOL_F; - m->level = 0; - m->waiting = make_queue (); - return scm_new_smob (scm_tc16_mutex | (mkind << 16), (scm_t_bits) m); + return scm_from_mutex (m); } #undef FUNC_NAME @@ -1113,7 +1139,7 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, SCM ret; SCM_VALIDATE_MUTEX (1, mutex); - m = SCM_MUTEX_DATA (mutex); + m = scm_to_mutex (mutex); if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) { @@ -1123,7 +1149,7 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, /* Specialized lock_mutex implementations according to the mutex kind. */ - switch (SCM_MUTEX_KIND (mutex)) + switch (mutex_kind (m)) { case SCM_MUTEX_STANDARD: ret = lock_mutex (SCM_MUTEX_STANDARD, m, t, waittime); @@ -1138,8 +1164,6 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, abort (); } - scm_remember_upto_here_1 (mutex); - return ret; } #undef FUNC_NAME @@ -1220,11 +1244,11 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), SCM_VALIDATE_MUTEX (1, mutex); - m = SCM_MUTEX_DATA (mutex); + m = scm_to_mutex (mutex); /* Specialized unlock_mutex implementations according to the mutex kind. */ - switch (SCM_MUTEX_KIND (mutex)) + switch (mutex_kind (m)) { case SCM_MUTEX_STANDARD: unlock_mutex (SCM_MUTEX_STANDARD, m, t); @@ -1239,8 +1263,6 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), abort (); } - scm_remember_upto_here_1 (mutex); - return SCM_BOOL_T; } #undef FUNC_NAME @@ -1263,7 +1285,7 @@ SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0, struct scm_mutex *m = NULL; SCM_VALIDATE_MUTEX (1, mx); - m = SCM_MUTEX_DATA (mx); + m = scm_to_mutex (mx); scm_i_pthread_mutex_lock (&m->lock); owner = m->owner; scm_i_pthread_mutex_unlock (&m->lock); @@ -1278,9 +1300,10 @@ SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0, #define FUNC_NAME s_scm_mutex_level { SCM_VALIDATE_MUTEX (1, mx); - if (SCM_MUTEX_KIND (mx) == SCM_MUTEX_RECURSIVE) - return scm_from_int (SCM_MUTEX_DATA (mx)->level + 1); - else if (scm_is_eq (SCM_MUTEX_DATA (mx)->owner, SCM_BOOL_F)) + struct scm_mutex *m = scm_to_mutex (mx); + if (mutex_kind (m) == SCM_MUTEX_RECURSIVE) + return scm_from_int (m->level + 1); + else if (scm_is_eq (m->owner, SCM_BOOL_F)) return SCM_INUM0; else return SCM_INUM1; @@ -1293,7 +1316,7 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, #define FUNC_NAME s_scm_mutex_locked_p { SCM_VALIDATE_MUTEX (1, mx); - if (scm_is_eq (SCM_MUTEX_DATA (mx)->owner, SCM_BOOL_F)) + if (scm_is_eq (scm_to_mutex (mx)->owner, SCM_BOOL_F)) return SCM_BOOL_F; else return SCM_BOOL_T; @@ -1304,17 +1327,30 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, struct scm_cond { - scm_i_pthread_mutex_t lock; + scm_t_bits tag; SCM waiting; /* the threads waiting for this condition. */ + /* FIXME: Using one cond with multiple mutexes may race on the waiting + list. */ }; -#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) -#define SCM_CONDVAR_DATA(x) ((struct scm_cond *) SCM_SMOB_DATA (x)) - -static int -scm_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) +static struct scm_cond* +scm_to_condvar (SCM x) { - struct scm_cond *c = SCM_CONDVAR_DATA (cv); + if (!SCM_CONDVARP (x)) abort (); + return (struct scm_cond*) SCM_UNPACK_POINTER (x); +} + +static SCM +scm_from_condvar (struct scm_cond *c) +{ + return SCM_PACK_POINTER (c); +} + +int +scm_i_print_condition_variable (SCM cv, SCM port, + scm_print_state *pstate SCM_UNUSED) +{ + struct scm_cond *c = scm_to_condvar (cv); scm_puts ("#", port); @@ -1326,14 +1362,11 @@ SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, "Make a new condition variable.") #define FUNC_NAME s_scm_make_condition_variable { - struct scm_cond *c; - SCM cv; - - c = scm_gc_malloc (sizeof (struct scm_cond), "condition variable"); - c->waiting = SCM_EOL; - SCM_NEWSMOB (cv, scm_tc16_condvar, (scm_t_bits) c); + struct scm_cond *c = + scm_gc_malloc (sizeof (struct scm_cond), "condition variable"); + c->tag = scm_tc16_condition_variable; c->waiting = make_queue (); - return cv; + return scm_from_condvar (c); } #undef FUNC_NAME @@ -1455,8 +1488,8 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, SCM_VALIDATE_CONDVAR (1, cond); SCM_VALIDATE_MUTEX (2, mutex); - c = SCM_CONDVAR_DATA (cond); - m = SCM_MUTEX_DATA (mutex); + c = scm_to_condvar (cond); + m = scm_to_mutex (mutex); if (!SCM_UNBNDP (timeout)) { @@ -1466,7 +1499,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, /* Specialized timed_wait implementations according to the mutex kind. */ - switch (SCM_MUTEX_KIND (mutex)) + switch (mutex_kind (m)) { case SCM_MUTEX_STANDARD: ret = timed_wait (SCM_MUTEX_STANDARD, m, c, t, waittime); @@ -1481,8 +1514,6 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, abort (); } - scm_remember_upto_here_2 (mutex, cond); - return ret; } #undef FUNC_NAME @@ -1494,7 +1525,7 @@ SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0, { struct scm_cond *c; SCM_VALIDATE_CONDVAR (1, cv); - c = SCM_CONDVAR_DATA (cv); + c = scm_to_condvar (cv); unblock_from_queue (c->waiting); return SCM_BOOL_T; } @@ -1507,7 +1538,7 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, { struct scm_cond *c; SCM_VALIDATE_CONDVAR (1, cv); - c = SCM_CONDVAR_DATA (cv); + c = scm_to_condvar (cv); while (scm_is_true (unblock_from_queue (c->waiting))) ; return SCM_BOOL_T; @@ -1831,9 +1862,6 @@ scm_threads_prehistory (struct gc_mutator *mut, struct gc_stack_addr base) guilify_self_1 (mut, base, 0); } -scm_t_bits scm_tc16_mutex; -scm_t_bits scm_tc16_condvar; - static void scm_init_ice_9_threads (void *unused) { @@ -1853,13 +1881,6 @@ scm_init_ice_9_threads (void *unused) void scm_init_threads () { - scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (struct scm_mutex)); - scm_set_smob_print (scm_tc16_mutex, scm_mutex_print); - - scm_tc16_condvar = scm_make_smob_type ("condition-variable", - sizeof (struct scm_cond)); - scm_set_smob_print (scm_tc16_condvar, scm_cond_print); - default_dynamic_state = SCM_BOOL_F; guilify_self_2 (scm_i_make_initial_dynamic_state ()); threads_initialized_p = 1; diff --git a/libguile/threads.h b/libguile/threads.h index 918e87c41..731085cc0 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -52,10 +52,6 @@ -/* smob tags for the thread datatypes */ -SCM_API scm_t_bits scm_tc16_mutex; -SCM_API scm_t_bits scm_tc16_condvar; - struct scm_thread_wake_data; struct gc_mutator; @@ -144,10 +140,6 @@ scm_thread_handle (struct scm_thread *thread) #define SCM_VALIDATE_THREAD(pos, a) \ SCM_ASSERT_TYPE (SCM_I_IS_THREAD (a), (a), (pos), FUNC_NAME, "thread") -#define SCM_VALIDATE_MUTEX(pos, a) \ - scm_assert_smob_type (scm_tc16_mutex, (a)) -#define SCM_VALIDATE_CONDVAR(pos, a) \ - scm_assert_smob_type (scm_tc16_condvar, (a)) SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data); @@ -161,6 +153,9 @@ SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex); SCM_INTERNAL int scm_i_print_thread (SCM t, SCM port, scm_print_state *pstate); +SCM_INTERNAL int scm_i_print_mutex (SCM m, SCM port, scm_print_state *pstate); +SCM_INTERNAL int scm_i_print_condition_variable (SCM cv, SCM port, + scm_print_state *pstate); SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_yield (void); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 203c7fc0e..b2f37064b 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -71,6 +71,7 @@ + ;; Numbers. @@ -82,7 +83,7 @@ ;; corresponding classes, which may be obtained via class-of, ;; once you have an instance. Perhaps FIXME to provide a ;; smob-type-name->class procedure. - + @@ -1083,6 +1084,8 @@ slots as we go." (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) @@ -3531,8 +3534,6 @@ var{initargs}." ;;; (define (find-subclass ')) -(define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass '))