From 378f262561cb381e8b3cff3faac1157605422015 Mon Sep 17 00:00:00 2001 From: Ludovic Courtes Date: Mon, 22 May 2006 19:12:12 +0000 Subject: [PATCH] Added support for SMOB custom mark procedures. * libguile/gc.c (scm_gc_mark): Removed. (scm_gc_mark_dependencies): Removed. (scm_mark_locations): Removed. * libguile/gc.h (scm_gc_mark_dependencies): Removed. (scm_mark_locations): Removed. * libguile/inline.h (scm_cell): Use `GC_MALLOC ()' instead of `GC_malloc ()'. * libguile/smob.c (smob_freelist): New. (smob_gc_kind): New. (smob_mark): New. (scm_gc_mark): New. (scm_i_new_smob_with_mark_proc): New. (scm_smob_prehistory): Initialize `smob_freelist' and `smob_gc_kind'. * libguile/smob.h (scm_i_new_smob_with_mark_proc): New declaration. (SCM_NEWSMOB): Use it if a mark procedure is available. (SCM_NEWSMOB2): Likewise. (SCM_NEWSMOB3): Likewise. * libguile/threads.c (guilify_self_1): Initialize the `current_mark_stack_*' fields. * libguile/threads.h (scm_i_thread)[current_mark_stack_ptr]: New field. [current_mark_stack_limit]: New field. git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-22 --- libguile/gc.c | 19 ------- libguile/gc.h | 2 - libguile/inline.h | 2 +- libguile/smob.c | 121 +++++++++++++++++++++++++++++++++++++++++++++ libguile/smob.h | 67 +++++++++++++++---------- libguile/threads.c | 2 + libguile/threads.h | 5 ++ 7 files changed, 170 insertions(+), 48 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 66cb12816..eba10038c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -889,25 +889,6 @@ scm_i_tag_name (scm_t_bits tag) } -/* - FIXME: Unimplemented procs! - -*/ - -void -scm_gc_mark (SCM o) -{ -} - -void -scm_gc_mark_dependencies (SCM o) -{ -} - -void -scm_mark_locations (SCM_STACKITEM x[], unsigned long n) -{ -} void diff --git a/libguile/gc.h b/libguile/gc.h index 905b6ebac..117301272 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -215,8 +215,6 @@ SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist); SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist); SCM_API void scm_i_gc (const char *what); SCM_API void scm_gc_mark (SCM p); -SCM_API void scm_gc_mark_dependencies (SCM p); -SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n); SCM_API int scm_in_heap_p (SCM value); SCM_API void scm_gc_sweep (void); diff --git a/libguile/inline.h b/libguile/inline.h index 122455cee..8d6c41717 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -71,7 +71,7 @@ SCM_C_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr) { - SCM cell = SCM_PACK ((scm_t_bits) (GC_malloc (sizeof (scm_t_cell)))); + SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell)))); /* Initialize the type slot last so that the cell is ignored by the GC until it is completely initialized. This is only relevant when the GC diff --git a/libguile/smob.c b/libguile/smob.c index a728cc78b..b0e95fe2f 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -485,12 +485,133 @@ free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } + +/* Marking SMOBs using user-supplied mark procedures. */ + +#include +#include + +/* The freelist and GC kind used for SMOB types that provide a custom mark + procedure. */ +static void **smob_freelist = NULL; +static int smob_gc_kind = 0; + +#define CURRENT_MARK_PTR \ + ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr)) +#define CURRENT_MARK_LIMIT \ + ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) + + +/* The generic SMOB mark procedure that gets called for SMOBs allocated with + `scm_i_new_smob_with_mark_proc ()'. */ +static struct GC_ms_entry * +smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + register SCM cell; + scm_t_bits tc, smobnum; + + cell = SCM_PACK ((scm_t_bits)addr); + tc = SCM_CELL_WORD_0 (cell); + smobnum = SCM_TC2SMOBNUM (tc); + + if (smobnum >= scm_numsmob) + abort (); + + mark_stack_ptr = GC_MARK_AND_PUSH (addr, mark_stack_ptr, + mark_stack_limit, NULL); + + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + + if (scm_smobs[smobnum].mark) + { + SCM obj; + + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; + SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit; + + /* Invoke the SMOB's mark procedure, which will in turn invoke + `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */ + obj = scm_smobs[smobnum].mark (cell); + + mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; + + if (SCM_NIMP (obj)) + /* Mark the returned object. */ + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj), + mark_stack_ptr, + mark_stack_limit, NULL); + + SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL; + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL; + } + + return mark_stack_ptr; + +} + +/* Mark object O. We assume that this function is only called during the + mark phase, i.e., from within `smob_mark ()' or one of its + descendents. */ +void +scm_gc_mark (SCM o) +{ + if (SCM_NIMP (o)) + { + /* At this point, the `current_mark_*' fields of the current thread + must be defined (they are set in `smob_mark ()'). */ + register struct GC_ms_entry *mark_stack_ptr; + + if (!CURRENT_MARK_PTR) + /* The function was not called from a mark procedure. */ + abort (); + + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o), + CURRENT_MARK_PTR, CURRENT_MARK_LIMIT, + NULL); + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; + } +} + +/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may + provide a custom mark procedure and it will be honored. */ +SCM +scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1, + scm_t_bits data2, scm_t_bits data3) +{ + /* Return a double cell. */ + SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell), + smob_gc_kind)); + + SCM_SET_CELL_WORD_3 (cell, data3); + SCM_SET_CELL_WORD_2 (cell, data2); + SCM_SET_CELL_WORD_1 (cell, data1); + SCM_SET_CELL_WORD_0 (cell, tc); + + return cell; +} + + + void scm_smob_prehistory () { long i; scm_t_bits tc; + smob_freelist = GC_new_free_list (); + smob_gc_kind = GC_new_kind ((void **)smob_freelist, + GC_MAKE_PROC (GC_new_proc (smob_mark), 0), + 0, 0); + scm_numsmob = 0; for (i = 0; i < MAX_SMOB_COUNT; ++i) { diff --git a/libguile/smob.h b/libguile/smob.h index a4d70c8be..0a0da8324 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -44,40 +44,55 @@ typedef struct scm_smob_descriptor int gsubr_type; /* Used in procprop.c */ } scm_smob_descriptor; + +SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc, + scm_t_bits, scm_t_bits, scm_t_bits); -#define SCM_NEWSMOB(z, tc, data) \ -do { \ - z = scm_cell ((tc), (scm_t_bits) (data)); \ -} while (0) -#define SCM_RETURN_NEWSMOB(tc, data) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \ - return __SCM_smob_answer; \ - } while (0) -#define SCM_NEWSMOB2(z, tc, data1, data2) \ -do { \ - z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \ -} while (0) +#define SCM_NEWSMOB(z, tc, data) \ +do \ + { \ + z = (scm_smobs[SCM_TC2SMOBNUM (tc)].mark \ + ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \ + 0, 0) \ + : scm_cell (tc, (scm_t_bits)(data))); \ + } \ +while (0) -#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \ - return __SCM_smob_answer; \ +#define SCM_RETURN_NEWSMOB(tc, data) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \ + return __SCM_smob_answer; \ } while (0) -#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ -do { \ - z = scm_double_cell ((tc), (scm_t_bits)(data1), \ - (scm_t_bits)(data2), (scm_t_bits)(data3)); \ -} while (0) +#define SCM_NEWSMOB2(z, tc, data1, data2) \ + SCM_NEWSMOB3 (z, tc, data1, data2, 0) + +#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \ + return __SCM_smob_answer; \ + } while (0) -#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \ - return __SCM_smob_answer; \ +#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ +do \ + { \ + z = (scm_smobs[SCM_TC2SMOBNUM (tc)].mark \ + ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1), \ + (scm_t_bits)(data2), \ + (scm_t_bits)(data3)) \ + : scm_double_cell ((tc), (scm_t_bits)(data1), \ + (scm_t_bits)(data2), \ + (scm_t_bits)(data3))); \ + } \ +while (0) + +#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \ + return __SCM_smob_answer; \ } while (0) diff --git a/libguile/threads.c b/libguile/threads.c index 197629066..a8d78530a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -406,6 +406,8 @@ guilify_self_1 (SCM_STACKITEM *base) scm_i_pthread_mutex_init (&t->heap_mutex, NULL); t->clear_freelists_p = 0; t->gc_running_p = 0; + t->current_mark_stack_ptr = NULL; + t->current_mark_stack_limit = NULL; t->exited = 0; t->freelist = SCM_EOL; diff --git a/libguile/threads.h b/libguile/threads.h index 7e33041e8..dced696ea 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -72,6 +72,11 @@ typedef struct scm_i_thread { int gc_running_p; /* non-zero while this thread does GC or a sweep. */ + /* Information about the Boehm-GC mark stack during the mark phase. This + is used by `scm_gc_mark ()'. */ + void *current_mark_stack_ptr; + void *current_mark_stack_limit; + /* Other thread local things. */ SCM dynamic_state; -- 2.20.1