diff options
Diffstat (limited to 'libguile/smob.c')
-rw-r--r-- | libguile/smob.c | 152 |
1 files changed, 150 insertions, 2 deletions
diff --git a/libguile/smob.c b/libguile/smob.c index a728cc78b..718442237 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -37,6 +37,10 @@ #include "libguile/smob.h" +#include "libguile/boehm-gc.h" +#include <gc/gc_mark.h> + + /* scm_smobs scm_numsmob @@ -456,12 +460,13 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), SCM scm_make_smob (scm_t_bits tc) { - long n = SCM_TC2SMOBNUM (tc); + scm_t_bits n = SCM_TC2SMOBNUM (tc); size_t size = scm_smobs[n].size; scm_t_bits data = (size > 0 ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) : 0); - return scm_cell (tc, data); + + SCM_RETURN_NEWSMOB (tc, data); } @@ -485,12 +490,155 @@ free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } + +/* Marking SMOBs using user-supplied mark procedures. */ + + +/* 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; + + +/* 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; + register scm_t_bits tc, smobnum; + + cell = PTR2SCM (addr); + + if (SCM_TYP7 (cell) != scm_tc7_smob) + /* It is likely that the GC passed us a pointer to a free-list element + which we must ignore (see warning in `gc/gc_mark.h'). */ + return mark_stack_ptr; + + tc = SCM_CELL_WORD_0 (cell); + smobnum = SCM_TC2SMOBNUM (tc); + + if (smobnum >= scm_numsmob) + /* The first word looks corrupt. */ + abort (); + + 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) +{ +#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)) + + 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; + } +#undef CURRENT_MARK_PTR +#undef CURRENT_MARK_LIMIT +} + +/* 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; +} + + +/* Finalize SMOB by calling its SMOB type's free function, if any. */ +void +scm_i_finalize_smob (GC_PTR ptr, GC_PTR data) +{ + SCM smob; + size_t (* free_smob) (SCM); + + smob = PTR2SCM (ptr); +#if 0 + printf ("finalizing SMOB %p (smobnum: %u)\n", + ptr, SCM_SMOBNUM (smob)); +#endif + + free_smob = scm_smobs[SCM_SMOBNUM (smob)].free; + if (free_smob) + free_smob (smob); +} + + 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) { |