diff options
Diffstat (limited to 'libguile')
| -rw-r--r-- | libguile/ChangeLog | 58 | ||||
| -rw-r--r-- | libguile/Makefile.am | 2 | ||||
| -rw-r--r-- | libguile/__scm.h | 128 | ||||
| -rw-r--r-- | libguile/_scm.h | 2 | ||||
| -rw-r--r-- | libguile/eval.c | 22 | ||||
| -rw-r--r-- | libguile/gc-freelist.c | 7 | ||||
| -rw-r--r-- | libguile/gc-malloc.c | 18 | ||||
| -rw-r--r-- | libguile/gc.c | 25 | ||||
| -rw-r--r-- | libguile/gc.h | 21 | ||||
| -rw-r--r-- | libguile/init.c | 5 | ||||
| -rw-r--r-- | libguile/inline.h | 38 | ||||
| -rw-r--r-- | libguile/null-threads.h | 2 | ||||
| -rw-r--r-- | libguile/pthread-threads.h | 63 | ||||
| -rw-r--r-- | libguile/snarf.h | 28 | ||||
| -rw-r--r-- | libguile/threads.c | 885 | ||||
| -rw-r--r-- | libguile/threads.h | 142 | ||||
| -rw-r--r-- | libguile/version.c | 18 |
17 files changed, 981 insertions, 483 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 20d720686..8d96c60bc 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,61 @@ +2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + These changes are the start of support for preemptive + multithreading. Marius and I have agreed that I commit this code + into the repository although it isn't thoroughly tested and surely + introduces many bugs. The bugs should only be exposed when using + threads, though. Signalling and error handling for threads is + very likely broken. Work on making the implementation cleaner and + more efficient is needed. + + * __scm.h (SCM_ALLOW_INTS_ONLY): Removed. + (SCM_NONREC_CRITICAL_SECTION_START, + SCM_NONREC_CRITICAL_SECTION_END, SCM_REC_CRITICAL_SECTION_START, + SCM_REC_CRITICAL_SECTION_END): New macros. + (SCM_CRITICAL_SECTION_START/END): Defined here. + + * eval.c: Insert SOURCE_SECTION_START / SOURCE_SECTION_END around + the three calls to scm_m_expand_body. + + * gc.h: #include "libguile/pthread-threads.h"; + (SCM_FREELIST_CREATE, SCM_FREELIST_LOC): New macros. + + * gc.c (scm_i_freelist, scm_i_freelist2): Defined to be of type + scm_t_key; + + * gc.c, gc-freelist.c, inline.h: Use SCM_FREELIST_LOC for freelist + access. + + * gc-freelist.c (scm_gc_init_freelist): Create freelist keys. + + * gc-freelist.c, threads.c (really_launch): Use + SCM_FREELIST_CREATE. + + * gc-malloc.c (scm_realloc, scm_gc_register_collectable_memory): + + * gc.c (scm_i_expensive_validation_check, scm_gc, + scm_gc_for_newcell): Put threads to sleep before doing GC-related + heap administration so that those pieces of code are executed + single-threaded. We might consider rewriting these code sections + in terms of a "call_gc_code_singly_threaded" construct instead of + calling the pair of scm_i_thread_put_to_sleep () and + scm_i_thread_wake_up (). Also, we would want to have as many of + these sections eleminated. + + * init.c (scm_init_guile_1): Call scm_threads_prehistory. + + * inline.h: #include "libguile/threads.h" + + * pthread-threads.h: Macros now conform more closely to the + pthreads interface. Some of them now take a second argument. + + * threads.c, threads.h: Many changes. + +2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se> + + * Makefile.am (version.h): Changed $^ --> $< in rule for + version.h. + 2002-12-08 Rob Browning <rlb@defaultvalue.org> * version.h.in (SCM_MICRO_VERSION): use @--@ substitution now. diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 78121c7fe..e91c320a8 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -181,7 +181,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \ ## usual @...@, so autoconf doesn't go and substitute the values ## directly into the left-hand sides of the sed substitutions. *sigh* version.h: version.h.in - sed < $^ > $@.tmp \ + sed < $< > $@.tmp \ -e s:@-GUILE_MAJOR_VERSION-@:${GUILE_MAJOR_VERSION}: \ -e s:@-GUILE_MINOR_VERSION-@:${GUILE_MINOR_VERSION}: \ -e s:@-GUILE_MICRO_VERSION-@:${GUILE_MICRO_VERSION}: diff --git a/libguile/__scm.h b/libguile/__scm.h index bb6a60a34..3cb666398 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -446,53 +446,46 @@ do { \ #define SCM_FENCE #endif -#define SCM_DEFER_INTS \ -do { \ - SCM_FENCE; \ - SCM_CHECK_NOT_DISABLED; \ - SCM_CRITICAL_SECTION_START; \ - SCM_FENCE; \ - scm_ints_disabled = 1; \ - SCM_FENCE; \ +#define SCM_DEFER_INTS \ +do { \ + SCM_FENCE; \ + SCM_CHECK_NOT_DISABLED; \ + SCM_REC_CRITICAL_SECTION_START (scm_i_defer); \ + SCM_FENCE; \ + scm_ints_disabled = 1; \ + SCM_FENCE; \ } while (0) -#define SCM_ALLOW_INTS_ONLY \ -do { \ - SCM_CRITICAL_SECTION_END; \ - scm_ints_disabled = 0; \ +#define SCM_ALLOW_INTS \ +do { \ + SCM_FENCE; \ + SCM_CHECK_NOT_ENABLED; \ + SCM_REC_CRITICAL_SECTION_END (scm_i_defer); \ + SCM_FENCE; \ + scm_ints_disabled = 0; \ + SCM_FENCE; \ + SCM_THREAD_SWITCHING_CODE; \ + SCM_FENCE; \ } while (0) -#define SCM_ALLOW_INTS \ -do { \ - SCM_FENCE; \ - SCM_CHECK_NOT_ENABLED; \ - SCM_CRITICAL_SECTION_END; \ - SCM_FENCE; \ - scm_ints_disabled = 0; \ - SCM_FENCE; \ - SCM_THREAD_SWITCHING_CODE; \ - SCM_FENCE; \ +#define SCM_REDEFER_INTS \ +do { \ + SCM_FENCE; \ + SCM_REC_CRITICAL_SECTION_START (scm_i_defer); \ + ++scm_ints_disabled; \ + SCM_FENCE; \ } while (0) -#define SCM_REDEFER_INTS \ -do { \ - SCM_FENCE; \ - SCM_CRITICAL_SECTION_START; \ - ++scm_ints_disabled; \ - SCM_FENCE; \ -} while (0) - - -#define SCM_REALLOW_INTS \ -do { \ - SCM_FENCE; \ - SCM_CRITICAL_SECTION_END; \ - SCM_FENCE; \ - --scm_ints_disabled; \ - SCM_FENCE; \ +#define SCM_REALLOW_INTS \ +do { \ + SCM_FENCE; \ + SCM_REC_CRITICAL_SECTION_END (scm_i_defer); \ + SCM_FENCE; \ + --scm_ints_disabled; \ + SCM_FENCE; \ } while (0) @@ -504,6 +497,65 @@ do { \ +/* Critical sections */ + +#define SCM_DECLARE_NONREC_CRITICAL_SECTION(prefix) \ + extern scm_t_mutex prefix ## _mutex + +#define SCM_NONREC_CRITICAL_SECTION_START(prefix) \ + do { scm_thread *t = scm_i_leave_guile (); \ + scm_i_plugin_mutex_lock (&prefix ## _mutex); \ + scm_i_enter_guile (t); \ + } while (0) + +#define SCM_NONREC_CRITICAL_SECTION_END(prefix) \ + do { scm_i_plugin_mutex_unlock (&prefix ## _mutex); \ + } while (0) + +/* This could be replaced by a single call to scm_i_plugin_mutex_lock + on systems which support recursive mutecis (like LinuxThreads). + We should test for the presence of recursive mutecis in + configure.in. + + Also, it is probably possible to replace recursive sections with + non-recursive ones, so don't worry about the complexity. + */ + +#define SCM_DECLARE_REC_CRITICAL_SECTION(prefix) \ + extern scm_t_mutex prefix ## _mutex; \ + extern int prefix ## _count; \ + extern scm_thread *prefix ## _owner + +#define SCM_REC_CRITICAL_SECTION_START(prefix) \ + do { scm_i_plugin_mutex_lock (&scm_i_section_mutex); \ + if (prefix ## _count && prefix ## _owner == SCM_CURRENT_THREAD) \ + { \ + ++prefix ## _count; \ + scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ + } \ + else \ + { \ + scm_thread *t = scm_i_leave_guile (); \ + scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ + scm_i_plugin_mutex_lock (&prefix ## _mutex); \ + prefix ## _count = 1; \ + prefix ## _owner = t; \ + scm_i_enter_guile (t); \ + } \ + } while (0) + +#define SCM_REC_CRITICAL_SECTION_END(prefix) \ + do { scm_i_plugin_mutex_lock (&scm_i_section_mutex); \ + if (!--prefix ## _count) \ + { \ + prefix ## _owner = 0; \ + scm_i_plugin_mutex_unlock (&prefix ## _mutex); \ + } \ + scm_i_plugin_mutex_unlock (&scm_i_section_mutex); \ + } while (0) + +/* Note: The following needs updating. */ + /* Classification of critical sections * * When Guile moves to POSIX threads, it won't be possible to prevent diff --git a/libguile/_scm.h b/libguile/_scm.h index 42870e787..3d25f1cb5 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -88,7 +88,7 @@ */ #ifdef HAVE_RESTARTABLE_SYSCALLS -#ifndef USE_COPT_THREADS /* However, don't assume SA_RESTART +#ifndef USE_PTHREAD_THREADS /* However, don't assume SA_RESTART works with pthreads... */ #define SCM_SYSCALL(line) line #endif diff --git a/libguile/eval.c b/libguile/eval.c index 7bdedd0d3..8ba26f293 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -152,6 +152,10 @@ char *alloca (); #define EXTEND_ENV SCM_EXTEND_ENV +SCM_REC_CRITICAL_SECTION (source); +#define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source); +#define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source); + SCM * scm_ilookup (SCM iloc, SCM env) { @@ -1580,7 +1584,11 @@ scm_eval_body (SCM code, SCM env) { if (SCM_ISYMP (SCM_CAR (code))) { - code = scm_m_expand_body (code, env); + SOURCE_SECTION_START; + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (code))) + code = scm_m_expand_body (code, env); + SOURCE_SECTION_END; goto again; } } @@ -1979,7 +1987,11 @@ dispatch: { if (SCM_ISYMP (form)) { - x = scm_m_expand_body (x, env); + SOURCE_SECTION_START; + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (x))) + x = scm_m_expand_body (x, env); + SOURCE_SECTION_END; goto nontoplevel_begin; } else @@ -3634,7 +3646,11 @@ tail: { if (SCM_ISYMP (SCM_CAR (proc))) { - proc = scm_m_expand_body (proc, args); + SOURCE_SECTION_START; + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (proc))) + proc = scm_m_expand_body (proc, args); + SOURCE_SECTION_END; goto again; } else diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c index 1b9780531..8fce129db 100644 --- a/libguile/gc-freelist.c +++ b/libguile/gc-freelist.c @@ -168,8 +168,11 @@ scm_gc_init_freelist (void) int init_heap_size_2 = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2); - scm_i_freelist = SCM_EOL; - scm_i_freelist2 = SCM_EOL; + /* These are the thread-local freelists. */ + scm_key_create (&scm_i_freelist, free); + scm_key_create (&scm_i_freelist2, free); + SCM_FREELIST_CREATE (scm_i_freelist); + SCM_FREELIST_CREATE (scm_i_freelist2); scm_init_freelist (&scm_i_master_freelist2, 2, scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2)); diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 54a162263..dd7e30432 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -130,15 +130,22 @@ scm_realloc (void *mem, size_t size) if (ptr) return ptr; + scm_i_thread_put_to_sleep (); + scm_i_sweep_all_segments ("realloc"); SCM_SYSCALL (ptr = realloc (mem, size)); if (ptr) - return ptr; + { + scm_i_thread_wake_up (); + return ptr; + } scm_igc ("realloc"); scm_i_sweep_all_segments ("realloc"); + scm_i_thread_wake_up (); + SCM_SYSCALL (ptr = realloc (mem, size)); if (ptr) return ptr; @@ -208,11 +215,14 @@ scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) */ if (scm_mallocated > scm_mtrigger) { - unsigned long prev_alloced = scm_mallocated; + unsigned long prev_alloced; float yield; + scm_i_thread_put_to_sleep (); + + prev_alloced = scm_mallocated; scm_igc (what); - scm_i_sweep_all_segments("mtrigger"); + scm_i_sweep_all_segments ("mtrigger"); yield = ((float)prev_alloced - (float) scm_mallocated) / (float) prev_alloced; @@ -243,6 +253,8 @@ scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n", scm_mtrigger); #endif } + + scm_i_thread_wake_up (); } #ifdef GUILE_DEBUG_MALLOC diff --git a/libguile/gc.c b/libguile/gc.c index 9c5de1d92..6ad9c4ec2 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -144,7 +144,9 @@ scm_i_expensive_validation_check (SCM cell) else { counter = scm_debug_cells_gc_interval; + scm_i_thread_put_to_sleep (); scm_igc ("scm_assert_cell_valid"); + scm_i_thread_wake_up (); } } } @@ -249,8 +251,8 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, -SCM scm_i_freelist = SCM_EOL; -SCM scm_i_freelist2 = SCM_EOL; +scm_t_key scm_i_freelist; +scm_t_key scm_i_freelist2; /* scm_mtrigger @@ -457,7 +459,9 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, #define FUNC_NAME s_scm_gc { SCM_DEFER_INTS; + scm_i_thread_put_to_sleep (); scm_igc ("call"); + scm_i_thread_wake_up (); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } @@ -475,6 +479,8 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) { SCM cell; + scm_i_thread_put_to_sleep (); + ++scm_ints_disabled; *free_cells = scm_i_sweep_some_segments (freelist); @@ -519,6 +525,7 @@ scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) *free_cells = SCM_FREE_CELL_CDR (cell); + scm_i_thread_wake_up (); return cell; } @@ -540,13 +547,17 @@ scm_igc (const char *what) fprintf (stderr,"gc reason %s\n", what); fprintf (stderr, - SCM_NULLP (scm_i_freelist) + SCM_NULLP (*SCM_FREELIST_LOC (scm_i_freelist)) ? "*" - : (SCM_NULLP (scm_i_freelist2) ? "o" : "m")); + : (SCM_NULLP (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m")); #endif /* During the critical section, only the current thread may run. */ +#if 0 /* MDJ 021207 <djurfeldt@nada.kth.se> + Currently, a much larger piece of the GC is single threaded. + Can we shrink it again? */ SCM_CRITICAL_SECTION_START; +#endif if (!scm_root || !scm_stack_base || scm_block_gc) { @@ -610,7 +621,9 @@ scm_igc (const char *what) scm_c_hook_run (&scm_after_sweep_c_hook, 0); gc_end_stats (); +#if 0 /* MDJ 021207 <djurfeldt@nada.kth.se> */ SCM_CRITICAL_SECTION_END; +#endif /* See above. @@ -1011,8 +1024,8 @@ scm_gc_sweep (void) /* When we move to POSIX threads private freelists should probably be GC-protected instead. */ - scm_i_freelist = SCM_EOL; - scm_i_freelist2 = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; } #undef FUNC_NAME diff --git a/libguile/gc.h b/libguile/gc.h index 6e1fec939..ebb7ff6e9 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -3,7 +3,7 @@ #ifndef SCM_GC_H #define SCM_GC_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. * * 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 @@ -50,6 +50,12 @@ #include "libguile/hooks.h" +#ifdef USE_PTHREAD_THREADS +#include "libguile/pthread-threads.h" +#else +#include "libguile/null-threads.h" +#endif + typedef struct scm_t_cell @@ -276,13 +282,14 @@ SCM_API size_t scm_default_max_segment_size; SCM_API size_t scm_max_segment_size; -/* - Deprecated scm_freelist, scm_master_freelist. - No warning; this is not a user serviceable part. - */ -extern SCM scm_i_freelist; +#define SCM_FREELIST_CREATE(key) \ + do { SCM *ls = (SCM *) malloc (sizeof (SCM)); \ + *ls = SCM_EOL; \ + scm_setspecific ((key), ls); } while (0) +#define SCM_FREELIST_LOC(key) ((SCM *) scm_getspecific (key)) +extern scm_t_key scm_i_freelist; +extern scm_t_key scm_i_freelist2; extern struct scm_t_cell_type_statistics scm_i_master_freelist; -extern SCM scm_i_freelist2; extern struct scm_t_cell_type_statistics scm_i_master_freelist2; diff --git a/libguile/init.c b/libguile/init.c index 0e0115385..076b05cad 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -444,14 +444,15 @@ scm_init_guile_1 (SCM_STACKITEM *base) scm_ints_disabled = 1; scm_block_gc = 1; - + + scm_threads_prehistory (); scm_ports_prehistory (); scm_smob_prehistory (); scm_tables_prehistory (); #ifdef GUILE_DEBUG_MALLOC scm_debug_malloc_prehistory (); #endif - if (scm_init_storage ()) /* requires smob_prehistory */ + if (scm_init_storage ()) /* requires threads and smob_prehistory */ abort (); scm_struct_prehistory (); /* requires storage */ diff --git a/libguile/inline.h b/libguile/inline.h index 419c9f0bc..7d5b20dba 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -57,6 +57,7 @@ #include "libguile/pairs.h" #include "libguile/gc.h" +#include "libguile/threads.h" SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); @@ -79,15 +80,23 @@ SCM scm_cell (scm_t_bits car, scm_t_bits cdr) { SCM z; + /* We retrieve the SCM pointer only once since the call to + SCM_FREELIST_LOC will be slightly expensive when we support + preemptive multithreading. SCM_FREELIST_DOC will then retrieve + the thread specific freelist. + + Until then, SCM_FREELIST_DOC expands to (&scm_i_freelist) and the + following code will compile to the same as if we had worked + directly on the scm_i_freelist variable. + */ + SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist); - if (SCM_NULLP (scm_i_freelist)) - { - z = scm_gc_for_newcell (&scm_i_master_freelist, &scm_i_freelist); - } + if (SCM_NULLP (*freelist)) + z = scm_gc_for_newcell (&scm_i_master_freelist, freelist); else { - z = scm_i_freelist; - scm_i_freelist = SCM_FREE_CELL_CDR (scm_i_freelist); + z = *freelist; + *freelist = SCM_FREE_CELL_CDR (*freelist); } /* @@ -136,6 +145,7 @@ scm_cell (scm_t_bits car, scm_t_bits cdr) SCM_GC_SET_CELL_WORD (z, 1, cdr); SCM_GC_SET_CELL_WORD (z, 0, car); +#if 0 /*fixme* Hmm... let's consider this later. */ #if !defined(USE_COOP_THREADS) && !defined(USE_NULL_THREADS) && !defined(USE_COPT_THREADS) /* When we are using preemtive threads, we might need to make sure that the initial values for the slots are protected until @@ -144,7 +154,7 @@ scm_cell (scm_t_bits car, scm_t_bits cdr) #error review me scm_remember_upto_here_1 (SCM_PACK (cdr)); #endif - +#endif #if (SCM_DEBUG_CELL_ACCESSES == 1) if (scm_expensive_debug_cell_accesses_p ) @@ -160,16 +170,14 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, scm_t_bits ccr, scm_t_bits cdr) { SCM z; + SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2); - - if (SCM_NULLP (scm_i_freelist2)) - { - z = scm_gc_for_newcell (&scm_i_master_freelist2, &scm_i_freelist2); - } + if (SCM_NULLP (*freelist)) + z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist); else { - z = scm_i_freelist2; - scm_i_freelist2 = SCM_FREE_CELL_CDR (scm_i_freelist2); + z = *freelist; + *freelist = SCM_FREE_CELL_CDR (*freelist); } scm_cells_allocated += 2; @@ -185,6 +193,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, SCM_GC_SET_CELL_WORD (z, 3, cdr); SCM_GC_SET_CELL_WORD (z, 0, car); +#if 0 /*fixme* Hmm... let's consider this later. */ #if !defined(USE_COOP_THREADS) && !defined(USE_NULL_THREADS) && !defined(USE_COPT_THREADS) /* When we are using non-cooperating threads, we might need to make sure that the initial values for the slots are protected until @@ -193,6 +202,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, #error review me scm_remember_upto_here_3 (SCM_PACK (cbr), SCM_PACK (ccr), SCM_PACK (cdr)); #endif +#endif #if (SCM_DEBUG_CELL_ACCESSES == 1) diff --git a/libguile/null-threads.h b/libguile/null-threads.h index 40eaa4292..14d40eea2 100644 --- a/libguile/null-threads.h +++ b/libguile/null-threads.h @@ -50,6 +50,8 @@ no new threads can be created. */ +#error temporarily broken, compile with threads enabled (default option) + /* We can't switch so don't bother trying. */ #undef SCM_THREAD_SWITCHING_CODE diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 5d68677ce..6e7e1d678 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -46,49 +46,52 @@ -/* The pthreads-threads implementation. This is a very simple mapping. +/* The pthreads-threads implementation. This is a direct mapping. */ +/* This is an interface between Guile and the pthreads thread package. */ + #include <pthread.h> -#define scm_t_thread pthread_t +/* MDJ 021209 <djurfeldt@nada.kth.se>: + The separation of the plugin interface and the low-level C API + (currently in threads.h) needs to be completed in a sensible way. + */ + +/* The scm_t_ types are temporarily used both in plugin and low-level API */ +#define scm_t_thread pthread_t -#define scm_thread_create(th,proc,data) \ - pthread_create ((th), NULL, (void *(*)(void *))(proc), (data)) +#define scm_i_plugin_thread_create pthread_create -#define scm_thread_join(th) pthread_join (th, NULL) -#define scm_thread_detach(th) pthread_detach (th) -#define scm_thread_self() pthread_self () +#define scm_i_plugin_thread_join pthread_join +#define scm_i_plugin_thread_detach pthread_detach +#define scm_i_plugin_thread_self pthread_self -#define scm_t_mutex pthread_mutex_t +#define scm_t_mutex pthread_mutex_t -#define scm_mutex_init(mx) pthread_mutex_init (mx, NULL) -#define scm_mutex_destroy(mx) pthread_mutex_destroy (mx) -#define scm_mutex_lock(mx) pthread_mutex_lock (mx) -#define scm_mutex_trylock(mx) pthread_mutex_trylock (mx) -#define scm_mutex_unlock(mx) pthread_mutex_unlock (mx) +#define scm_i_plugin_mutex_init pthread_mutex_init +#define scm_i_plugin_mutex_destroy pthread_mutex_destroy +#define scm_i_plugin_mutex_lock pthread_mutex_lock +#define scm_i_plugin_mutex_trylock pthread_mutex_trylock +#define scm_i_plugin_mutex_unlock pthread_mutex_unlock -#define scm_t_cond pthread_cond_t +#define scm_t_cond pthread_cond_t -#define scm_cond_init(cv) pthread_cond_init (cv, NULL) -#define scm_cond_destroy(cv) pthread_cond_destroy (cv) -#define scm_cond_wait(cv,mx) pthread_cond_wait (cv, mx) -#define scm_cond_timedwait(cv,mx,at) \ - pthread_cond_timedwait (cv, mx, at) -#define scm_cond_signal(cv) pthread_cond_signal (cv) -#define scm_cond_broadcast(cv) \ - pthread_cond_broadcast (cv) +#define scm_i_plugin_cond_init pthread_cond_init +#define scm_i_plugin_cond_destroy pthread_cond_destroy +#define scm_i_plugin_cond_wait pthread_cond_wait +#define scm_i_plugin_cond_timedwait pthread_cond_timedwait +#define scm_i_plugin_cond_signal pthread_cond_signal +#define scm_i_plugin_cond_broadcast pthread_cond_broadcast -#define scm_t_key pthread_key_t +#define scm_t_key pthread_key_t -#define scm_key_create(keyp) pthread_key_create (keyp, NULL) -#define scm_key_delete(key) pthread_key_delete (key) -#define scm_key_setspecific(key, value) \ - pthread_setspecific (key, value) -#define scm_key_getspecific(key) \ - pthread_getspecific (key) +#define scm_i_plugin_key_create pthread_key_create +#define scm_i_plugin_key_delete pthread_key_delete +#define scm_i_plugin_setspecific pthread_setspecific +#define scm_i_plugin_getspecific pthread_getspecific -#define scm_thread_select select +#define scm_i_plugin_select select #endif /* SCM_THREADS_NULL_H */ diff --git a/libguile/snarf.h b/libguile/snarf.h index 50565bedd..3b7f1e77f 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -203,6 +203,34 @@ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_va SCM_SNARF_HERE(SCM c_name) \ SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));) +#define SCM_NONREC_CRITICAL_SECTION(prefix) \ +SCM_SNARF_HERE(static scm_t_mutex prefix ## _mutex) \ +SCM_SNARF_INIT(scm_i_plugin_mutex_init (&prefix ## _mutex, 0)) + +#define SCM_GLOBAL_NONREC_CRITICAL_SECTION(prefix) \ +SCM_SNARF_HERE(scm_t_mutex prefix ## _mutex) \ +SCM_SNARF_INIT(scm_i_plugin_mutex_init (&prefix ## _mutex, 0)) + +#define SCM_REC_CRITICAL_SECTION(prefix) \ +SCM_SNARF_HERE(\ +static scm_t_mutex prefix ## _mutex; \ +static int prefix ## _count; \ +static scm_thread *prefix ## _owner\ +)SCM_SNARF_INIT(\ +scm_i_plugin_mutex_init (&prefix ## _mutex, 0)\ +) + +#define SCM_GLOBAL_REC_CRITICAL_SECTION(prefix) \ +SCM_SNARF_HERE(\ +scm_t_mutex prefix ## _mutex; \ +int prefix ## _count; \ +scm_thread *prefix ## _owner\ +)SCM_SNARF_INIT(\ +scm_i_plugin_mutex_init (&prefix ## _mutex, 0); \ +prefix ## _count = 0; \ +prefix ## _owner = 0\ +) + #ifdef SCM_MAGIC_SNARF_DOCS #undef SCM_ASSERT #define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^ diff --git a/libguile/threads.c b/libguile/threads.c index d36d3bcc7..4e3c9132b 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -114,16 +114,22 @@ dequeue (SCM q) } } - /*** Threads */ -typedef struct scm_thread { +#define THREAD_INITIALIZED_P(t) (t->base != NULL) + +struct scm_thread { /* Blocking. */ scm_t_cond sleep_cond; struct scm_thread *next_waiting; + /* This mutex represents this threads right to access the heap. + That right can temporarily be taken away by the GC. */ + scm_t_mutex heap_mutex; + int clear_freelists_p; /* set if GC was done while thread was asleep */ + scm_root_state *root; SCM handle; scm_t_thread thread; @@ -137,7 +143,7 @@ typedef struct scm_thread { SCM_STACKITEM *top; jmp_buf regs; -} scm_thread; +}; static SCM make_thread (SCM creation_protects) @@ -150,26 +156,19 @@ make_thread (SCM creation_protects) t->result = creation_protects; t->base = NULL; t->joining_threads = make_queue (); - scm_cond_init (&t->sleep_cond); + scm_i_plugin_cond_init (&t->sleep_cond, 0); + scm_i_plugin_mutex_init (&t->heap_mutex, 0); + t->clear_freelists_p = 0; t->exited = 0; return z; } static void -init_thread_creator (SCM thread, scm_t_thread th, scm_root_state *r) +init_thread_creatant (SCM thread, + SCM_STACKITEM *base) { - scm_thread *t = SCM_THREAD_DATA(thread); - t->root = r; - t->thread = th; -#ifdef DEBUG - // fprintf (stderr, "%ld created %ld\n", pthread_self (), th); -#endif -} - -static void -init_thread_creatant (SCM thread, SCM_STACKITEM *base) -{ - scm_thread *t = SCM_THREAD_DATA(thread); + scm_thread *t = SCM_THREAD_DATA (thread); + t->thread = scm_thread_self (); t->base = base; t->top = NULL; } @@ -180,7 +179,7 @@ thread_mark (SCM obj) scm_thread *t = SCM_THREAD_DATA (obj); scm_gc_mark (t->result); scm_gc_mark (t->joining_threads); - return t->root->handle; + return t->root->handle; /* mark root-state of this thread */ } static int @@ -203,160 +202,43 @@ thread_free (SCM obj) return 0; } -/*** Fair mutexes */ - -/* C level mutexes (such as POSIX mutexes) are not necessarily fair - but since we'd like to use a mutex for scheduling, we build a fair - one on top of the C one. -*/ - -typedef struct fair_mutex { - scm_t_mutex lock; - scm_thread *owner; - scm_thread *next_waiting, *last_waiting; -} fair_mutex; - -static void -fair_mutex_init (fair_mutex *m) -{ - scm_mutex_init (&m->lock); - m->owner = NULL; - m->next_waiting = NULL; - m->last_waiting = NULL; -} - -static void -fair_mutex_lock_1 (fair_mutex *m, scm_thread *t) -{ - if (m->owner == NULL) - m->owner = t; - else - { - t->next_waiting = NULL; - if (m->last_waiting) - m->last_waiting->next_waiting = t; - else - m->next_waiting = t; - m->last_waiting = t; - do - { - int err; - err = scm_cond_wait (&t->sleep_cond, &m->lock); - assert (err == 0); - } - while (m->owner != t); - assert (m->next_waiting == t); - m->next_waiting = t->next_waiting; - if (m->next_waiting == NULL) - m->last_waiting = NULL; - } - scm_mutex_unlock (&m->lock); -} - -static void -fair_mutex_lock (fair_mutex *m, scm_thread *t) -{ - scm_mutex_lock (&m->lock); - fair_mutex_lock_1 (m, t); -} - -static void -fair_mutex_unlock_1 (fair_mutex *m) -{ - scm_thread *t; - scm_mutex_lock (&m->lock); - // fprintf (stderr, "%ld unlocking\n", m->owner->pthread); - if ((t = m->next_waiting) != NULL) - { - m->owner = t; - scm_cond_signal (&t->sleep_cond); - } - else - m->owner = NULL; - // fprintf (stderr, "%ld unlocked\n", pthread_self ()); -} - -static void -fair_mutex_unlock (fair_mutex *m) -{ - fair_mutex_unlock_1 (m); - scm_mutex_unlock (&m->lock); -} - -/* Temporarily give up the mutex. This function makes sure that we - are on the wait queue before starting the next thread. Otherwise - the next thread might preempt us and we will have a hard time - getting on the wait queue. -*/ -static void -fair_mutex_yield (fair_mutex *m) -{ - scm_thread *self = m->owner; - fair_mutex_unlock_1 (m); - fair_mutex_lock_1 (m, self); -} - -static int -fair_cond_wait (scm_t_cond *c, fair_mutex *m) -{ - scm_thread *t = m->owner; - int err; - fair_mutex_unlock_1 (m); - err = scm_cond_wait (c, &m->lock); - fair_mutex_lock_1 (m, t); - return err; -} - -static int -fair_cond_timedwait (scm_t_cond *c, fair_mutex *m, struct timespec *at) -{ - int err; - scm_thread *t = m->owner; - fair_mutex_unlock_1 (m); - err = scm_cond_timedwait (c, &m->lock, at); /* XXX - signals? */ - fair_mutex_lock_1 (m, t); - return err; -} - /*** Scheduling */ -/* When a thread wants to execute Guile functions, it locks the - guile_mutex. -*/ - -static fair_mutex guile_mutex; - -static SCM cur_thread; -void *scm_i_thread_data; +#define cur_thread (SCM_CURRENT_THREAD->handle) +scm_t_key scm_i_thread_key; +scm_t_key scm_i_root_state_key; void scm_i_set_thread_data (void *data) { - scm_thread *t = SCM_THREAD_DATA (cur_thread); - scm_i_thread_data = data; + scm_thread *t = SCM_CURRENT_THREAD; + scm_setspecific (scm_i_root_state_key, data); t->root = (scm_root_state *)data; } static void resume (scm_thread *t) { - cur_thread = t->handle; - scm_i_thread_data = t->root; t->top = NULL; + if (t->clear_freelists_p) + { + *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; + t->clear_freelists_p = 0; + } } -static void -enter_guile (scm_thread *t) +void +scm_i_enter_guile (scm_thread *t) { - fair_mutex_lock (&guile_mutex, t); + scm_i_plugin_mutex_lock (&t->heap_mutex); resume (t); } static scm_thread * suspend () { - SCM cur = cur_thread; - scm_thread *c = SCM_THREAD_DATA (cur); + scm_thread *c = SCM_CURRENT_THREAD; /* record top of stack for the GC */ c->top = (SCM_STACKITEM *)&c; @@ -367,30 +249,12 @@ suspend () return c; } -static scm_thread * -leave_guile () +scm_thread * +scm_i_leave_guile () { - scm_thread *c = suspend (); - fair_mutex_unlock (&guile_mutex); - return c; -} - -int scm_i_switch_counter; - -SCM -scm_yield () -{ - /* Testing guile_mutex.next_waiting without locking guile_mutex.lock - is OK since the outcome is not critical. Even when it changes - after the test, we do the right thing. - */ - if (guile_mutex.next_waiting) - { - scm_thread *t = suspend (); - fair_mutex_yield (&guile_mutex); - resume (t); - } - return SCM_BOOL_T; + scm_thread *t = suspend (); + scm_i_plugin_mutex_unlock (&t->heap_mutex); + return t; } /* Put the current thread to sleep until it is explicitely unblocked. @@ -400,7 +264,7 @@ block () { int err; scm_thread *t = suspend (); - err = fair_cond_wait (&t->sleep_cond, &guile_mutex); + err = scm_i_plugin_cond_wait (&t->sleep_cond, &t->heap_mutex); resume (t); return err; } @@ -410,11 +274,11 @@ block () reached. Return 0 when it has been unblocked; errno otherwise. */ static int -timed_block (struct timespec *at) +timed_block (const struct timespec *at) { int err; scm_thread *t = suspend (); - err = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at); + err = scm_i_plugin_cond_timedwait (&t->sleep_cond, &t->heap_mutex, at); resume (t); return err; } @@ -424,11 +288,12 @@ timed_block (struct timespec *at) static void unblock (scm_thread *t) { - scm_cond_signal (&t->sleep_cond); + scm_i_plugin_cond_signal (&t->sleep_cond); } /*** Thread creation */ +static scm_t_mutex thread_admin_mutex; static SCM all_threads; static int thread_count; @@ -459,11 +324,17 @@ handler_bootstrip (launch_data* data, SCM tag, SCM throw_args) static void really_launch (SCM_STACKITEM *base, launch_data *data) { - SCM thread = data->thread; - scm_thread *t = SCM_THREAD_DATA (thread); - init_thread_creatant (thread, base); - enter_guile (t); - + SCM thread; + scm_thread *t; + thread = data->thread; + t = SCM_THREAD_DATA (thread); + SCM_FREELIST_CREATE (scm_i_freelist); + SCM_FREELIST_CREATE (scm_i_freelist2); + scm_setspecific (scm_i_thread_key, t); + scm_setspecific (scm_i_root_state_key, t->root); + scm_i_plugin_mutex_lock (&t->heap_mutex); /* ensure that we "own" the heap */ + init_thread_creatant (thread, base); /* must own the heap */ + data->rootcont = SCM_BOOL_F; t->result = scm_internal_cwdr ((scm_t_catch_body) body_bootstrip, @@ -473,16 +344,19 @@ really_launch (SCM_STACKITEM *base, launch_data *data) free (data); scm_thread_detach (t->thread); - all_threads = scm_delq (thread, all_threads); + scm_i_plugin_mutex_lock (&thread_admin_mutex); + all_threads = scm_delq_x (thread, all_threads); t->exited = 1; thread_count--; - leave_guile (); + scm_i_plugin_mutex_unlock (&thread_admin_mutex); + /* We're leaving with heap_mutex still locked. */ } -static void +static void * launch_thread (void *p) { really_launch ((SCM_STACKITEM *)&p, (launch_data *)p); + return 0; } static SCM @@ -500,8 +374,9 @@ create_thread (scm_t_catch_body body, void *body_data, { scm_t_thread th; - SCM root, old_winds; + SCM root, old_winds, new_threads; launch_data *data; + scm_thread *t; int err; /* Unwind wind chain. */ @@ -519,15 +394,30 @@ create_thread (scm_t_catch_body body, void *body_data, data->body_data = body_data; data->handler = handler; data->handler_data = handler_data; - err = scm_thread_create (&th, launch_thread, (void *) data); - if (err == 0) + t = SCM_THREAD_DATA (thread); + /* must initialize root state pointer before the thread is linked + into all_threads */ + t->root = SCM_ROOT_STATE (root); + + /* In order to avoid the need of synchronization between parent + and child thread, we need to insert the child into all_threads + before creation. */ + new_threads = scm_cons (thread, SCM_BOOL_F); /* could cause GC */ + scm_i_plugin_mutex_lock (&thread_admin_mutex); + SCM_SETCDR (new_threads, all_threads); + all_threads = new_threads; + thread_count++; + scm_i_plugin_mutex_unlock (&thread_admin_mutex); + + err = scm_i_plugin_thread_create (&th, 0, launch_thread, (void *) data); + if (err != 0) { - init_thread_creator (thread, th, SCM_ROOT_STATE (root)); - all_threads = scm_cons (thread, all_threads); - thread_count++; + scm_i_plugin_mutex_lock (&thread_admin_mutex); + all_threads = scm_delq_x (thread, all_threads); + ((scm_thread *) SCM_THREAD_DATA(thread))->exited = 1; + thread_count--; + scm_i_plugin_mutex_unlock (&thread_admin_mutex); } - else - ((scm_thread *)SCM_THREAD_DATA(thread))->exited = 1; /* Return to old dynamic context. */ scm_dowinds (old_winds, - scm_ilength (old_winds)); @@ -564,13 +454,6 @@ SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 2, 0, 0, } #undef FUNC_NAME -SCM -scm_spawn_thread (scm_t_catch_body body, void *body_data, - scm_t_catch_handler handler, void *handler_data) -{ - return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F); -} - SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, (SCM thread), "Suspend execution of the calling thread until the target @var{thread} " @@ -587,9 +470,11 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, t = SCM_THREAD_DATA (thread); if (!t->exited) { - scm_thread *c = leave_guile (); - scm_thread_join (t->thread); - enter_guile (c); + scm_thread *c = scm_i_leave_guile (); + while (!THREAD_INITIALIZED_P (t)) + SCM_TICK; + scm_thread_join (t->thread, 0); + scm_i_enter_guile (c); } res = t->result; t->result = SCM_BOOL_F; @@ -597,7 +482,7 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, } #undef FUNC_NAME -/*** Mutexes */ +/*** Fair mutexes */ /* We implement our own mutex type since we want them to be 'fair', we want to do fancy things while waiting for them (like running @@ -605,30 +490,34 @@ SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0, Also, we might add things that are nice for debugging. */ -typedef struct scm_mutex { +typedef struct fair_mutex { /* the thread currently owning the mutex, or SCM_BOOL_F. */ + scm_t_mutex lock; + int lockedp; SCM owner; /* how much the owner owns us. */ int level; /* the threads waiting for this mutex. */ SCM waiting; -} scm_mutex; +} fair_mutex; static SCM -mutex_mark (SCM mx) +fair_mutex_mark (SCM mx) { - scm_mutex *m = SCM_MUTEX_DATA (mx); + fair_mutex *m = SCM_MUTEX_DATA (mx); scm_gc_mark (m->owner); return m->waiting; } -SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0, +SCM_DEFINE (scm_make_fair_mutex, "make-fair-mutex", 0, 0, 0, (void), - "Create a new mutex object. ") -#define FUNC_NAME s_scm_make_mutex + "Create a new fair mutex object. ") +#define FUNC_NAME s_scm_make_fair_mutex { - SCM mx = scm_make_smob (scm_tc16_mutex); - scm_mutex *m = SCM_MUTEX_DATA (mx); + SCM mx = scm_make_smob (scm_tc16_fair_mutex); + fair_mutex *m = SCM_MUTEX_DATA (mx); + scm_i_plugin_mutex_init (&m->lock, 0); + m->lockedp = 0; m->owner = SCM_BOOL_F; m->level = 0; m->waiting = make_queue (); @@ -636,19 +525,19 @@ SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, - (SCM mx), -"Lock @var{mutex}. If the mutex is already locked, the calling thread " -"blocks until the mutex becomes available. The function returns when " -"the calling thread owns the lock on @var{mutex}. Locking a mutex that " -"a thread already owns will succeed right away and will not block the " -"thread. That is, Guile's mutexes are @emph{recursive}. ") -#define FUNC_NAME s_scm_lock_mutex +static int +fair_mutex_lock (fair_mutex *m) { - scm_mutex *m; - SCM_VALIDATE_MUTEX (1, mx); - m = SCM_MUTEX_DATA (mx); - + scm_i_plugin_mutex_lock (&m->lock); +#if 0 + /* Need to wait if another thread is just temporarily unlocking. + This is happens very seldom and only when the other thread is + between scm_mutex_unlock and scm_i_plugin_mutex_lock below. */ + while (m->lockedp) + SCM_TICK; + m->lockedp = 1; +#endif + if (m->owner == SCM_BOOL_F) m->owner = cur_thread; else if (m->owner == cur_thread) @@ -658,63 +547,51 @@ SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, while (1) { SCM c = enqueue (m->waiting, cur_thread); - int err = block (); + int err; + /* Note: It's important that m->lock is never locked for + any longer amount of time since that could prevent GC */ + scm_i_plugin_mutex_unlock (&m->lock); + err = block (); if (m->owner == cur_thread) - return SCM_BOOL_T; + return 0; + scm_i_plugin_mutex_lock (&m->lock); remqueue (m->waiting, c); + scm_i_plugin_mutex_unlock (&m->lock); if (err) - { - errno = err; - scm_syserror (FUNC_NAME); - } + return err; SCM_ASYNC_TICK; + scm_i_plugin_mutex_lock (&m->lock); } } - return SCM_BOOL_T; + scm_i_plugin_mutex_unlock (&m->lock); + return 0; } -#undef FUNC_NAME -SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, - (SCM mx), -"Try to lock @var{mutex}. If the mutex is already locked by someone " -"else, return @code{#f}. Else lock the mutex and return @code{#t}. ") -#define FUNC_NAME s_scm_try_mutex +static int +fair_mutex_trylock (fair_mutex *m) { - scm_mutex *m; - SCM_VALIDATE_MUTEX (1, mx); - m = SCM_MUTEX_DATA (mx); - + scm_i_plugin_mutex_lock (&m->lock); if (m->owner == SCM_BOOL_F) m->owner = cur_thread; else if (m->owner == cur_thread) m->level++; else - return SCM_BOOL_F; - return SCM_BOOL_T; + { + scm_i_plugin_mutex_unlock (&m->lock); + return EBUSY; + } + scm_i_plugin_mutex_unlock (&m->lock); + return 0; } -#undef FUNC_NAME -SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, - (SCM mx), -"Unlocks @var{mutex} if the calling thread owns the lock on " -"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current " -"thread results in undefined behaviour. Once a mutex has been unlocked, " -"one thread blocked on @var{mutex} is awakened and grabs the mutex " -"lock. Every call to @code{lock-mutex} by this thread must be matched " -"with a call to @code{unlock-mutex}. Only the last call to " -"@code{unlock-mutex} will actually unlock the mutex. ") -#define FUNC_NAME s_scm_unlock_mutex +static int +fair_mutex_unlock (fair_mutex *m) { - scm_mutex *m; - SCM_VALIDATE_MUTEX (1, mx); - m = SCM_MUTEX_DATA (mx); - + scm_i_plugin_mutex_lock (&m->lock); if (m->owner != cur_thread) { - if (m->owner == SCM_BOOL_F) - SCM_MISC_ERROR ("mutex not locked", SCM_EOL); - else - SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); + scm_i_plugin_mutex_unlock (&m->lock); + return EPERM; } else if (m->level > 0) m->level--; @@ -725,44 +602,224 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, { m->owner = next; unblock (SCM_THREAD_DATA (next)); - scm_yield (); } else m->owner = SCM_BOOL_F; } - return SCM_BOOL_T; + scm_i_plugin_mutex_unlock (&m->lock); + return 0; } -#undef FUNC_NAME -/*** Condition variables */ +/*** Fair condition variables */ /* Like mutexes, we implement our own condition variables using the primitives above. */ -/* yeah, we don't need a structure for this, but more things (like a - name) will likely follow... */ - -typedef struct scm_cond { +typedef struct fair_cond { + scm_t_mutex lock; /* the threads waiting for this condition. */ SCM waiting; -} scm_cond; +} fair_cond; static SCM -cond_mark (SCM cv) +fair_cond_mark (SCM cv) { - scm_cond *c = SCM_CONDVAR_DATA (cv); + fair_cond *c = SCM_CONDVAR_DATA (cv); return c->waiting; } +SCM_DEFINE (scm_make_fair_condition_variable, "make-fair-condition-variable", 0, 0, 0, + (void), + "Make a new fair condition variable.") +#define FUNC_NAME s_scm_make_fair_condition_variable +{ + SCM cv = scm_make_smob (scm_tc16_fair_condvar); + fair_cond *c = SCM_CONDVAR_DATA (cv); + scm_i_plugin_mutex_init (&c->lock, 0); + c->waiting = make_queue (); + return cv; +} +#undef FUNC_NAME + +static int +fair_cond_timedwait (fair_cond *c, + fair_mutex *m, + const struct timespec *waittime) +{ + int err; + scm_i_plugin_mutex_lock (&c->lock); + + while (1) + { + enqueue (c->waiting, cur_thread); + scm_i_plugin_mutex_unlock (&c->lock); + fair_mutex_unlock (m); /*fixme* - not thread safe */ + if (waittime == NULL) + err = block (); + else + err = timed_block (waittime); + fair_mutex_lock (m); + if (err) + return err; + /* XXX - check whether we have been signalled. */ + break; + } + return err; +} + +static int +fair_cond_signal (fair_cond *c) +{ + SCM th; + scm_i_plugin_mutex_lock (&c->lock); + if (!SCM_FALSEP (th = dequeue (c->waiting))) + unblock (SCM_THREAD_DATA (th)); + scm_i_plugin_mutex_unlock (&c->lock); + return 0; +} + +static int +fair_cond_broadcast (fair_cond *c) +{ + SCM th; + scm_i_plugin_mutex_lock (&c->lock); + while (!SCM_FALSEP (th = dequeue (c->waiting))) + unblock (SCM_THREAD_DATA (th)); + scm_i_plugin_mutex_unlock (&c->lock); + return 0; +} + +/*** Mutexes */ + +SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0, + (void), + "Create a new mutex object. ") +#define FUNC_NAME s_scm_make_mutex +{ + SCM mx = scm_make_smob (scm_tc16_mutex); + scm_i_plugin_mutex_init (SCM_MUTEX_DATA (mx), 0); + return mx; +} +#undef FUNC_NAME + +/*fixme* change documentation */ +SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0, + (SCM mx), +"Lock @var{mutex}. If the mutex is already locked, the calling thread " +"blocks until the mutex becomes available. The function returns when " +"the calling thread owns the lock on @var{mutex}. Locking a mutex that " +"a thread already owns will succeed right away and will not block the " +"thread. That is, Guile's mutexes are @emph{recursive}. ") +#define FUNC_NAME s_scm_lock_mutex +{ + int err; + SCM_VALIDATE_MUTEX (1, mx); + + if (SCM_TYP16 (mx) == scm_tc16_fair_mutex) + err = fair_mutex_lock (SCM_MUTEX_DATA (mx)); + else + { + scm_t_mutex *m = SCM_MUTEX_DATA (mx); + scm_thread *t = scm_i_leave_guile (); + err = scm_i_plugin_mutex_lock (m); + scm_i_enter_guile (t); + } + + if (err) + { + errno = err; + SCM_SYSERROR; + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, + (SCM mx), +"Try to lock @var{mutex}. If the mutex is already locked by someone " +"else, return @code{#f}. Else lock the mutex and return @code{#t}. ") +#define FUNC_NAME s_scm_try_mutex +{ + int err; + SCM_VALIDATE_MUTEX (1, mx); + + if (SCM_TYP16 (mx) == scm_tc16_fair_mutex) + err = fair_mutex_trylock (SCM_MUTEX_DATA (mx)); + else + { + scm_t_mutex *m = SCM_MUTEX_DATA (mx); + scm_thread *t = scm_i_leave_guile (); + err = scm_i_plugin_mutex_trylock (m); + scm_i_enter_guile (t); + } + + if (err == EBUSY) + return SCM_BOOL_F; + + if (err) + { + errno = err; + SCM_SYSERROR; + } + + return SCM_BOOL_T; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, + (SCM mx), +"Unlocks @var{mutex} if the calling thread owns the lock on " +"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current " +"thread results in undefined behaviour. Once a mutex has been unlocked, " +"one thread blocked on @var{mutex} is awakened and grabs the mutex " +"lock. Every call to @code{lock-mutex} by this thread must be matched " +"with a call to @code{unlock-mutex}. Only the last call to " +"@code{unlock-mutex} will actually unlock the mutex. ") +#define FUNC_NAME s_scm_unlock_mutex +{ + int err; + SCM_VALIDATE_MUTEX (1, mx); + + if (SCM_TYP16 (mx) == scm_tc16_fair_mutex) + { + err = fair_mutex_unlock (SCM_MUTEX_DATA (mx)); + if (err == EPERM) + { + fair_mutex *m = SCM_MUTEX_DATA (mx); + if (m->owner != cur_thread) + { + if (m->owner == SCM_BOOL_F) + SCM_MISC_ERROR ("mutex not locked", SCM_EOL); + else + SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL); + } + } + } + else + { + scm_t_mutex *m = SCM_MUTEX_DATA (mx); + err = scm_i_plugin_mutex_unlock (m); + } + + if (err) + { + errno = err; + SCM_SYSERROR; + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + +/*** Condition variables */ + SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, (void), "Make a new condition variable.") #define FUNC_NAME s_scm_make_condition_variable { SCM cv = scm_make_smob (scm_tc16_condvar); - scm_cond *c = SCM_CONDVAR_DATA (cv); - c->waiting = make_queue (); + scm_i_plugin_cond_init (SCM_CONDVAR_DATA (cv), 0); return cv; } #undef FUNC_NAME @@ -780,19 +837,24 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, "is returned. ") #define FUNC_NAME s_scm_timed_wait_condition_variable { - scm_cond *c; struct timespec waittime; int err; SCM_VALIDATE_CONDVAR (1, cv); SCM_VALIDATE_MUTEX (2, mx); - + if (!((SCM_TYP16 (cv) == scm_tc16_condvar + && SCM_TYP16 (mx) == scm_tc16_mutex) + || (SCM_TYP16 (cv) == scm_tc16_fair_condvar + && SCM_TYP16 (mx) == scm_tc16_fair_mutex))) + SCM_MISC_ERROR ("Condition variable and mutex are of different kinds.", + SCM_EOL); + if (!SCM_UNBNDP (t)) { if (SCM_CONSP (t)) { - SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec); - SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec); + SCM_VALIDATE_UINT_COPY (3, SCM_CAR (t), waittime.tv_sec); + SCM_VALIDATE_UINT_COPY (3, SCM_CDR (t), waittime.tv_nsec); waittime.tv_nsec *= 1000; } else @@ -802,48 +864,41 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, } } - c = SCM_CONDVAR_DATA (cv); + if (SCM_TYP16 (cv) == scm_tc16_fair_condvar) + err = fair_cond_timedwait (SCM_CONDVAR_DATA (cv), + SCM_MUTEX_DATA (mx), + SCM_UNBNDP (t) ? NULL : &waittime); + else + { + scm_t_cond *c = SCM_CONDVAR_DATA (cv); + scm_t_mutex *m = SCM_MUTEX_DATA (mx); + scm_thread *t = scm_i_leave_guile (); + err = scm_i_plugin_cond_wait (c, m); + scm_i_enter_guile (t); + } - while (1) + if (err) { - enqueue (c->waiting, cur_thread); - scm_unlock_mutex (mx); - if (SCM_UNBNDP (t)) - err = block (); - else - err = timed_block (&waittime); - scm_lock_mutex (mx); - if (err) - { - errno = err; - scm_syserror (FUNC_NAME); - } - /* XXX - check whether we have been signalled. */ - break; + errno = err; + SCM_SYSERROR; } - return SCM_BOOL (err == 0); + return SCM_BOOL_T; } #undef FUNC_NAME -SCM -scm_wait_condition_variable (SCM c, SCM m) -{ - return scm_timed_wait_condition_variable (c, m, SCM_UNDEFINED); -} - SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0, (SCM cv), "Wake up one thread that is waiting for @var{cv}") #define FUNC_NAME s_scm_signal_condition_variable { - SCM th; - scm_cond *c; - SCM_VALIDATE_CONDVAR (1, cv); - - c = SCM_CONDVAR_DATA (cv); - if (!SCM_FALSEP (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); + if (SCM_TYP16 (cv) == scm_tc16_fair_condvar) + fair_cond_signal (SCM_CONDVAR_DATA (cv)); + else + { + scm_t_cond *c = SCM_CONDVAR_DATA (cv); + scm_i_plugin_cond_signal (c); + } return SCM_BOOL_T; } #undef FUNC_NAME @@ -853,14 +908,14 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, "Wake up all threads that are waiting for @var{cv}. ") #define FUNC_NAME s_scm_broadcast_condition_variable { - SCM th; - scm_cond *c; - SCM_VALIDATE_CONDVAR (1, cv); - - c = SCM_CONDVAR_DATA (cv); - while (!SCM_FALSEP (th = dequeue (c->waiting))) - unblock (SCM_THREAD_DATA (th)); + if (SCM_TYP16 (cv) == scm_tc16_fair_condvar) + fair_cond_broadcast (SCM_CONDVAR_DATA (cv)); + else + { + scm_t_cond *c = SCM_CONDVAR_DATA (cv); + scm_i_plugin_cond_broadcast (c); + } return SCM_BOOL_T; } #undef FUNC_NAME @@ -892,19 +947,24 @@ scm_threads_mark_stacks (void) for (c = all_threads; !SCM_NULLP (c); c = SCM_CDR (c)) { scm_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); - if (t->base == NULL) + if (!THREAD_INITIALIZED_P (t)) { /* Not fully initialized yet. */ continue; } if (t->top == NULL) { + long stack_len; +#ifdef SCM_DEBUG + if (t->thread != scm_thread_self ()) + abort (); +#endif /* Active thread */ /* stack_len is long rather than sizet in order to guarantee that &stack_len is long aligned */ #ifdef STACK_GROWS_UP - long stack_len = ((SCM_STACKITEM *) (&t) - - (SCM_STACKITEM *) thread->base); + stack_len = ((SCM_STACKITEM *) (&t) - + (SCM_STACKITEM *) thread->base); /* Protect from the C stack. This must be the first marking * done because it provides information about what objects @@ -924,8 +984,8 @@ scm_threads_mark_stacks (void) scm_mark_locations (((size_t) t->base, (sizet) stack_len)); #else - long stack_len = ((SCM_STACKITEM *) t->base - - (SCM_STACKITEM *) (&t)); + stack_len = ((SCM_STACKITEM *) t->base - + (SCM_STACKITEM *) (&t)); /* Protect from the C stack. This must be the first marking * done because it provides information about what objects @@ -973,15 +1033,65 @@ scm_internal_select (int nfds, struct timeval *timeout) { int res, eno; - scm_thread *c = leave_guile (); - res = scm_thread_select (nfds, readfds, writefds, exceptfds, timeout); + scm_thread *c = scm_i_leave_guile (); + res = scm_i_plugin_select (nfds, readfds, writefds, exceptfds, timeout); eno = errno; - enter_guile (c); + scm_i_enter_guile (c); SCM_ASYNC_TICK; errno = eno; return res; } +/* Low-level C API */ + +SCM +scm_spawn_thread (scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data) +{ + return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F); +} + +#if 0 +int +scm_mutex_lock (scm_t_mutex *m) +{ + scm_thread *t = scm_i_leave_guile (); + int res = scm_i_plugin_mutex_lock (m); + scm_i_enter_guile (t); + return res; +} + +int +scm_cond_wait (scm_t_cond *c, scm_t_mutex *m) +{ + scm_thread *t = scm_i_leave_guile (); + scm_i_plugin_cond_wait (c, m); + scm_i_enter_guile (t); + return 0; +} + +int +scm_cond_timedwait (scm_t_cond *c, scm_t_mutex *m) +{ + scm_thread *t = scm_i_leave_guile (); + int res = scm_i_plugin_cond_timedwait (c, m); + scm_i_enter_guile (t); + return res; +} +#endif + +void +scm_enter_guile () +{ + scm_i_enter_guile (SCM_CURRENT_THREAD); +} + +void +scm_leave_guile () +{ + scm_i_leave_guile (); +} + unsigned long scm_thread_usleep (unsigned long usecs) { @@ -1016,7 +1126,7 @@ SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0, SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0, (void), "Return a list of all threads.") -#define FUNC_NAME s_all_threads +#define FUNC_NAME s_scm_all_threads { return all_threads; } @@ -1025,7 +1135,7 @@ SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0, scm_root_state * scm_i_thread_root (SCM thread) { - return ((scm_thread *)SCM_THREAD_DATA (thread))->root; + return ((scm_thread *) SCM_THREAD_DATA (thread))->root; } SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0, @@ -1048,41 +1158,135 @@ scm_c_thread_exited_p (SCM thread) } #undef FUNC_NAME +static scm_t_cond wake_up_cond; +int scm_i_thread_go_to_sleep; +static scm_thread *gc_thread; +static scm_t_mutex gc_section_mutex; +static scm_thread *gc_section_owner; +static int gc_section_count = 0; +static int threads_initialized_p = 0; + +void +scm_i_thread_put_to_sleep () +{ + SCM_REC_CRITICAL_SECTION_START (gc_section); + if (threads_initialized_p && gc_section_count == 1) + { + SCM threads = all_threads; + /* Signal all threads to go to sleep */ + scm_i_thread_go_to_sleep = 1; + for (; !SCM_NULLP (threads); threads = SCM_CDR (threads)) + if (SCM_CAR (threads) != cur_thread) + { + scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); + t->clear_freelists_p = 1; + scm_i_plugin_mutex_lock (&t->heap_mutex); + } + gc_thread = suspend (); + scm_i_thread_go_to_sleep = 0; + } +} + +void +scm_i_thread_wake_up () +{ + if (threads_initialized_p && gc_section_count == 1) + { + SCM threads = all_threads; + resume (gc_thread); + scm_i_plugin_cond_broadcast (&wake_up_cond); + for (; !SCM_NULLP (threads); threads = SCM_CDR (threads)) + if (SCM_CAR (threads) != cur_thread) + { + scm_thread *t = SCM_THREAD_DATA (SCM_CAR (threads)); + scm_i_plugin_mutex_unlock (&t->heap_mutex); + } + } + SCM_REC_CRITICAL_SECTION_END (gc_section); +} + +void +scm_i_thread_sleep_for_gc () +{ + scm_thread *t; + t = suspend (); + *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; + *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; + scm_i_plugin_cond_wait (&wake_up_cond, &t->heap_mutex); + t->clear_freelists_p = 0; + t->top = NULL; /* resume (t); but don't clear freelists */ +} + +/* The mother of all recursive critical sections */ +scm_t_mutex scm_i_section_mutex; + +scm_t_mutex scm_i_critical_section_mutex; +scm_t_mutex scm_i_defer_mutex; +int scm_i_defer_count = 0; +scm_thread *scm_i_defer_owner = 0; + /*** Initialization */ +void +scm_threads_prehistory () +{ + scm_thread *t; + scm_i_plugin_mutex_init (&thread_admin_mutex, 0); + scm_i_plugin_mutex_init (&gc_section_mutex, 0); + scm_i_plugin_cond_init (&wake_up_cond, 0); + scm_i_plugin_mutex_init (&scm_i_critical_section_mutex, 0); + thread_count = 1; + scm_i_plugin_key_create (&scm_i_thread_key, 0); + scm_i_plugin_key_create (&scm_i_root_state_key, 0); + scm_i_plugin_mutex_init (&scm_i_defer_mutex, 0); + scm_i_plugin_mutex_init (&scm_i_section_mutex, 0); + /* Allocate a fake thread object to be used during bootup. */ + t = malloc (sizeof (scm_thread)); + t->base = NULL; + t->clear_freelists_p = 0; + scm_setspecific (scm_i_thread_key, t); +} + scm_t_bits scm_tc16_thread; scm_t_bits scm_tc16_mutex; +scm_t_bits scm_tc16_fair_mutex; scm_t_bits scm_tc16_condvar; +scm_t_bits scm_tc16_fair_condvar; void scm_init_threads (SCM_STACKITEM *base) { + SCM thread; scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_thread)); - scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_mutex)); + scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_t_mutex)); + scm_tc16_fair_mutex = scm_make_smob_type ("fair-mutex", + sizeof (fair_mutex)); scm_tc16_condvar = scm_make_smob_type ("condition-variable", - sizeof (scm_cond)); - - scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; + sizeof (scm_t_cond)); + scm_tc16_fair_condvar = scm_make_smob_type ("fair-condition-variable", + sizeof (fair_cond)); - fair_mutex_init (&guile_mutex); + thread = make_thread (SCM_BOOL_F); + /* Replace initial fake thread with a real thread object */ + free (SCM_CURRENT_THREAD); + scm_setspecific (scm_i_thread_key, SCM_THREAD_DATA (thread)); + scm_i_enter_guile (SCM_CURRENT_THREAD); - cur_thread = make_thread (SCM_BOOL_F); - enter_guile (SCM_THREAD_DATA (cur_thread)); /* root is set later from init.c */ - init_thread_creator (cur_thread, scm_thread_self(), NULL); - init_thread_creatant (cur_thread, base); - + init_thread_creatant (thread, base); thread_count = 1; scm_gc_register_root (&all_threads); - all_threads = scm_cons (cur_thread, SCM_EOL); + all_threads = scm_cons (thread, SCM_EOL); scm_set_smob_mark (scm_tc16_thread, thread_mark); scm_set_smob_print (scm_tc16_thread, thread_print); scm_set_smob_free (scm_tc16_thread, thread_free); - scm_set_smob_mark (scm_tc16_mutex, mutex_mark); + scm_set_smob_mark (scm_tc16_fair_mutex, fair_mutex_mark); + + scm_set_smob_mark (scm_tc16_fair_condvar, fair_cond_mark); - scm_set_smob_mark (scm_tc16_condvar, cond_mark); + threads_initialized_p = 1; } void @@ -1103,4 +1307,3 @@ scm_init_iselect () c-file-style: "gnu" End: */ - diff --git a/libguile/threads.h b/libguile/threads.h index df83f75c8..a3bdb2d91 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -56,72 +56,152 @@ /* smob tags for the thread datatypes */ SCM_API scm_t_bits scm_tc16_thread; SCM_API scm_t_bits scm_tc16_mutex; +SCM_API scm_t_bits scm_tc16_fair_mutex; SCM_API scm_t_bits scm_tc16_condvar; +SCM_API scm_t_bits scm_tc16_fair_condvar; -#define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x) -#define SCM_THREAD_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_THREADP(x) SCM_TYP16_PREDICATE (scm_tc16_thread, x) +#define SCM_THREAD_DATA(x) ((scm_thread *) SCM_CELL_WORD_1 (x)) -#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_MUTEXP(x) SCM_TYP16_PREDICATE (scm_tc16_mutex, x) +#define SCM_FAIR_MUTEX_P(x) SCM_TYP16_PREDICATE (scm_tc16_fair_mutex, x) +#define SCM_MUTEX_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) -#define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x) -#define SCM_CONDVAR_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) +#define SCM_CONDVARP(x) SCM_TYP16_PREDICATE (scm_tc16_condvar, x) +#define SCM_FAIR_CONDVAR_P(x) SCM_TYP16_PREDICATE (scm_tc16_fair_condvar, x) +#define SCM_CONDVAR_DATA(x) ((void *) SCM_CELL_WORD_1 (x)) #define SCM_VALIDATE_THREAD(pos, a) \ SCM_MAKE_VALIDATE_MSG (pos, a, THREADP, "thread") #define SCM_VALIDATE_MUTEX(pos, a) \ - SCM_MAKE_VALIDATE_MSG (pos, a, MUTEXP, "mutex") + SCM_ASSERT_TYPE (SCM_MUTEXP (a) || SCM_FAIR_MUTEX_P (a), \ + a, pos, FUNC_NAME, "mutex"); #define SCM_VALIDATE_CONDVAR(pos, a) \ - SCM_MAKE_VALIDATE_MSG (pos, a, CONDVARP, "condition variable") + SCM_ASSERT_TYPE (SCM_CONDVARP (a) || SCM_FAIR_CONDVAR_P (a), \ + a, pos, FUNC_NAME, "condition variable"); SCM_API void scm_threads_mark_stacks (void); SCM_API void scm_init_threads (SCM_STACKITEM *); SCM_API void scm_init_thread_procs (void); +/*----------------------------------------------------------------------*/ +/* Low-level C API */ + +/* The purpose of this API is seamless, simple and thread package + independent interaction with Guile threads from the application. + */ + +/* MDJ 021209 <djurfeldt@nada.kth.se>: + The separation of the plugin interface (currently in + pthread-threads.h and null-threads.h) and the low-level C API needs + to be completed in a sensible way. + */ + +/* Deprecate this name and rename to scm_thread_create? + Introduce the other two arguments in pthread_create to prepare for + the future? + */ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data); +#define scm_thread_join scm_i_plugin_thread_join +#define scm_thread_detach scm_i_plugin_thread_detach +#define scm_thread_self scm_i_plugin_thread_self + +#define scm_mutex_init scm_i_plugin_mutex_init +#define scm_mutex_destroy scm_i_plugin_mutex_destroy +SCM_API int scm_mutex_lock (scm_t_mutex *m); +#define scm_mutex_trylock scm_i_plugin_mutex_trylock +#define scm_mutex_unlock scm_i_plugin_mutex_unlock + +#define scm_cond_init scm_i_plugin_cond_init +#define scm_cond_destroy scm_i_plugin_cond_destroy +SCM_API int scm_cond_wait (scm_t_cond *c, scm_t_mutex *m); +SCM_API int scm_cond_timedwait (scm_t_cond *c, + scm_t_mutex *m, + const struct timespec *t); +#define scm_cond_signal scm_i_plugin_cond_signal +#define scm_cond_broadcast scm_i_plugin_cond_broadcast + +#define scm_key_create scm_i_plugin_key_create +#define scm_key_delete scm_i_plugin_key_delete +#define scm_setspecific scm_i_plugin_setspecific +#define scm_getspecific scm_i_plugin_getspecific + +#define scm_thread_select scm_internal_select + +/* The application must scm_leave_guile() before entering any piece of + code which can + 1. block, or + 2. execute for any longer period of time without calling SCM_TICK + + Note, though, that it is *not* necessary to use these calls + together with any call in this API. + */ + +SCM_API void scm_enter_guile (void); +SCM_API void scm_leave_guile (void); + +/* Better versions (although we need the former ones also in order to + avoid forcing code restructuring in existing applications): */ +/*fixme* Not implemented yet! */ +SCM_API void *scm_in_guile (void (*func) (void*), void *data); +SCM_API void *scm_outside_guile (void (*func) (void*), void *data); + /* These are versions of the ordinary sleep and usleep functions that play nicely with the thread system. */ SCM_API unsigned long scm_thread_sleep (unsigned long); SCM_API unsigned long scm_thread_usleep (unsigned long); +/* End of low-level C API */ +/*----------------------------------------------------------------------*/ + +typedef struct scm_thread scm_thread; + +SCM_API void scm_i_enter_guile (scm_thread *t); +SCM_API scm_thread *scm_i_leave_guile (void); + /* Critical sections */ -/* Since only one thread can be active anyway, we don't need to do - anything special around critical sections. In fact, that's the - reason we do only support cooperative threading: Guile's critical - regions have not been completely identified yet. (I think.) */ +SCM_API scm_t_mutex scm_i_section_mutex; + +/* This is the generic critical section for places where we are too + lazy to allocate a specific mutex. */ +SCM_DECLARE_NONREC_CRITICAL_SECTION (scm_i_critical_section); +#define SCM_CRITICAL_SECTION_START \ + SCM_NONREC_CRITICAL_SECTION_START (scm_i_critical_section) +#define SCM_CRITICAL_SECTION_END \ + SCM_NONREC_CRITICAL_SECTION_END (scm_i_critical_section) -#define SCM_CRITICAL_SECTION_START -#define SCM_CRITICAL_SECTION_END +/* This is the temporary support for the old ALLOW/DEFER ints sections */ +SCM_DECLARE_REC_CRITICAL_SECTION (scm_i_defer); -/* Switching */ +extern int scm_i_thread_go_to_sleep; -SCM_API int scm_i_switch_counter; -#define SCM_I_THREAD_SWITCH_COUNT 50 +void scm_i_thread_put_to_sleep (void); +void scm_i_thread_wake_up (void); +void scm_i_thread_sleep_for_gc (void); +void scm_threads_prehistory (void); +void scm_threads_init_first_thread (void); #define SCM_THREAD_SWITCHING_CODE \ do { \ - scm_i_switch_counter--; \ - if (scm_i_switch_counter == 0) \ - { \ - scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; \ - scm_yield(); \ - } \ + if (scm_i_thread_go_to_sleep) \ + scm_i_thread_sleep_for_gc (); \ } while (0) /* The C versions of the Scheme-visible thread functions. */ -SCM_API SCM scm_yield (void); SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_join_thread (SCM t); SCM_API SCM scm_make_mutex (void); +SCM_API SCM scm_make_fair_mutex (void); SCM_API SCM scm_lock_mutex (SCM m); SCM_API SCM scm_try_mutex (SCM m); SCM_API SCM scm_unlock_mutex (SCM m); SCM_API SCM scm_make_condition_variable (void); +SCM_API SCM scm_make_fair_condition_variable (void); SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex); SCM_API SCM scm_timed_wait_condition_variable (SCM cond, SCM mutex, SCM abstime); @@ -136,10 +216,16 @@ SCM_API SCM scm_thread_exited_p (SCM thread); SCM_API scm_root_state *scm_i_thread_root (SCM thread); -SCM_API void *scm_i_thread_data; -SCM_API void scm_i_set_thread_data (void *); -#define SCM_THREAD_LOCAL_DATA scm_i_thread_data +#define SCM_CURRENT_THREAD \ + ((scm_thread *) scm_i_plugin_getspecific (scm_i_thread_key)) +extern scm_t_key scm_i_thread_key; + +/* These macros have confusing names. + They really refer to the root state of the running thread. */ +#define SCM_THREAD_LOCAL_DATA (scm_i_plugin_getspecific (scm_i_root_state_key)) #define SCM_SET_THREAD_LOCAL_DATA(x) scm_i_set_thread_data(x) +extern scm_t_key scm_i_root_state_key; +SCM_API void scm_i_set_thread_data (void *); #ifndef HAVE_STRUCT_TIMESPEC /* POSIX.4 structure for a time value. This is like a `struct timeval' but @@ -151,7 +237,7 @@ struct timespec }; #endif -#ifdef USE_COPT_THREADS +#ifdef USE_PTHREAD_THREADS #include "libguile/pthread-threads.h" #else #include "libguile/null-threads.h" diff --git a/libguile/version.c b/libguile/version.c index cd973e8be..5e53b46f9 100644 --- a/libguile/version.c +++ b/libguile/version.c @@ -59,7 +59,7 @@ SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0, "E.g., the 1 in \"1.6.5\".") #define FUNC_NAME s_scm_major_version { - return scm_number_to_string (SCM_MAKINUM(SCM_MAJOR_VERSION), + return scm_number_to_string (SCM_MAKINUM(1), SCM_MAKINUM(10)); } #undef FUNC_NAME @@ -72,7 +72,7 @@ SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0, "E.g., the 6 in \"1.6.5\".") #define FUNC_NAME s_scm_minor_version { - return scm_number_to_string (SCM_MAKINUM(SCM_MINOR_VERSION), + return scm_number_to_string (SCM_MAKINUM(7), SCM_MAKINUM(10)); } #undef FUNC_NAME @@ -85,7 +85,7 @@ SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0, "E.g., the 5 in \"1.6.5\".") #define FUNC_NAME s_scm_micro_version { - return scm_number_to_string (SCM_MAKINUM(SCM_MICRO_VERSION), + return scm_number_to_string (SCM_MAKINUM(0), SCM_MAKINUM(10)); } #undef FUNC_NAME @@ -110,15 +110,17 @@ SCM_DEFINE (scm_version, "version", 0, 0, 0, char version_str[3 * 4 + 3]; +#if 0 #if SCM_MAJOR_VERSION > 9999 \ || SCM_MINOR_VERSION > 9999 \ || SCM_MICRO_VERSION > 9999 # error version string may overflow buffer #endif +#endif sprintf (version_str, "%d.%d.%d", - SCM_MAJOR_VERSION, - SCM_MINOR_VERSION, - SCM_MICRO_VERSION); + 1, + 7, + 0); return scm_makfrom0str (version_str); } #undef FUNC_NAME @@ -140,10 +142,12 @@ SCM_DEFINE (scm_effective_version, "effective-version", 0, 0, 0, char version_str[2 * 4 + 3]; +#if 0 #if (SCM_MAJOR_VERSION > 9999 || SCM_MINOR_VERSION > 9999) # error version string may overflow buffer #endif - sprintf (version_str, "%d.%d", SCM_MAJOR_VERSION, SCM_MINOR_VERSION); +#endif + sprintf (version_str, "%d.%d", 1, 7); return scm_makfrom0str (version_str); } #undef FUNC_NAME |