wingo pushed a commit to branch wip-whippet
in repository guile.
commit f47fe6e7520348a8cf254947a08750c6f6889c3c
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri Jun 13 11:45:55 2025 +0200
Convert mutexes, condition vars to statically-allocated tc16
* libguile/scm.h: Add statically allocated tc16s for condvars and
mutexes.
* libguile/threads.c: Adapt to declare tag inline to struct scm_cond and
struct scm_mutex.
* libguile/threads.h: Expose printing procedures internally.
* module/oop/goops.scm:
* libguile/goops.c: Fix to statically allocate condition variable and
mutex classes.
* libguile/eq.c:
* libguile/print.c: Adapt.
---
libguile/eq.c | 3 ++
libguile/goops.c | 8 ++++
libguile/print.c | 6 +++
libguile/scm.h | 13 ++++++
libguile/threads.c | 129 ++++++++++++++++++++++++++++++---------------------
libguile/threads.h | 11 ++---
module/oop/goops.scm | 7 +--
7 files changed, 112 insertions(+), 65 deletions(-)
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 ("<ephemeron>"));
class_ephemeron_table = scm_variable_ref (scm_c_lookup
("<ephemeron-table>"));
class_character_set = scm_variable_ref (scm_c_lookup ("<character-set>"));
+ class_condition_variable = scm_variable_ref (scm_c_lookup
("<condition-variable>"));
+ class_mutex = scm_variable_ref (scm_c_lookup ("<mutex>"));
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
@@ -74,6 +74,15 @@
+#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
/* FIXME: For the moment, the bodies of thread objects are traced
conservatively; only bdw, heap-conservative-mmc, and
@@ -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 struct scm_mutex*
+scm_to_mutex (SCM x)
+{
+ if (!SCM_MUTEXP (x)) abort ();
+ return (struct scm_mutex*) SCM_UNPACK_POINTER (x);
+}
-static int
-scm_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
+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_MUTEX_DATA (mx);
+ struct scm_mutex *m = scm_to_mutex (mx);
scm_puts ("#<mutex ", port);
scm_uintprint ((scm_t_bits)m, 16, port);
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 struct scm_cond*
+scm_to_condvar (SCM x)
+{
+ if (!SCM_CONDVARP (x)) abort ();
+ return (struct scm_cond*) SCM_UNPACK_POINTER (x);
+}
-static int
-scm_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
+static SCM
+scm_from_condvar (struct scm_cond *c)
{
- struct scm_cond *c = SCM_CONDVAR_DATA (cv);
+ 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 ("#<condition-variable ", port);
scm_uintprint ((scm_t_bits)c, 16, port);
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 @@
<fluid> <dynamic-state> <frame> <vm> <vm-continuation>
<keyword> <syntax> <atomic-box> <thread> <bitvector>
<finalizer> <ephemeron> <ephemeron-table> <character-set>
+ <mutex> <condition-variable>
;; Numbers.
<number> <complex> <real> <integer> <fraction>
@@ -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.
- <promise> <mutex> <condition-variable>
+ <promise>
<regexp> <hook> <random-state>
<directory> <array>
<dynamic-object> <macro>
@@ -1083,6 +1084,8 @@ slots as we go."
(define-standard-class <ephemeron> (<top>))
(define-standard-class <ephemeron-table> (<top>))
(define-standard-class <character-set> (<top>))
+(define-standard-class <condition-variable> (<top>))
+(define-standard-class <mutex> (<top>))
(define-standard-class <thread> (<top>))
(define-standard-class <number> (<top>))
(define-standard-class <complex> (<number>))
@@ -3531,8 +3534,6 @@ var{initargs}."
;;;
(define <promise> (find-subclass <top> '<promise>))
-(define <mutex> (find-subclass <top> '<mutex>))
-(define <condition-variable> (find-subclass <top> '<condition-variable>))
(define <regexp> (find-subclass <top> '<regexp>))
(define <hook> (find-subclass <top> '<hook>))
(define <bitvector> (find-subclass <top> '<bitvector>))
