diff options
Diffstat (limited to 'libguile/smob.c')
-rw-r--r-- | libguile/smob.c | 122 |
1 files changed, 83 insertions, 39 deletions
diff --git a/libguile/smob.c b/libguile/smob.c index 8b038f5de..0c3a5441b 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -105,14 +105,14 @@ int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { long n = SCM_SMOBNUM (exp); - scm_puts ("#<", port); - scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); - scm_putc (' ', port); + scm_puts_unlocked ("#<", port); + scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); + scm_putc_unlocked (' ', port); if (scm_smobs[n].size) scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); else scm_uintprint (SCM_UNPACK (exp), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); return 1; } @@ -415,16 +415,13 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), } static SCM tramp_weak_map = SCM_BOOL_F; -static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; SCM scm_i_smob_apply_trampoline (SCM smob) { SCM tramp; - scm_i_pthread_mutex_lock (&tramp_lock); - tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F); - scm_i_pthread_mutex_unlock (&tramp_lock); + tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F); if (scm_is_true (tramp)) return tramp; @@ -438,15 +435,13 @@ scm_i_smob_apply_trampoline (SCM smob) name = "smob-apply"; objtable = scm_c_make_vector (2, SCM_UNDEFINED); SCM_SIMPLE_VECTOR_SET (objtable, 0, smob); - SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name)); + SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_utf8_symbol (name)); tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode, objtable, SCM_BOOL_F); /* Race conditions (between the ref and this set!) cannot cause any harm here. */ - scm_i_pthread_mutex_lock (&tramp_lock); - scm_hashq_set_x (tramp_weak_map, smob, tramp); - scm_i_pthread_mutex_unlock (&tramp_lock); + scm_weak_table_putq_x (tramp_weak_map, smob, tramp); return tramp; } } @@ -472,8 +467,8 @@ scm_make_smob (scm_t_bits tc) static int smob_gc_kind; -/* The generic SMOB mark procedure that gets called for SMOBs allocated with - `scm_i_new_smob_with_mark_proc ()'. */ +/* The generic SMOB mark procedure that gets called for SMOBs allocated + with smob_gc_kind. */ 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) @@ -481,7 +476,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, register SCM cell; register scm_t_bits tc, smobnum; - cell = PTR2SCM (addr); + cell = SCM_PACK_POINTER (addr); if (SCM_TYP7 (cell) != scm_tc7_smob) /* It is likely that the GC passed us a pointer to a free-list element @@ -518,7 +513,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; - if (SCM_NIMP (obj)) + if (SCM_HEAP_OBJECT_P (obj)) /* Mark the returned object. */ mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj), mark_stack_ptr, @@ -543,7 +538,7 @@ scm_gc_mark (SCM o) #define CURRENT_MARK_LIMIT \ ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) - if (SCM_NIMP (o)) + if (SCM_HEAP_OBJECT_P (o)) { /* At this point, the `current_mark_*' fields of the current thread must be defined (they are set in `smob_mark ()'). */ @@ -562,33 +557,15 @@ scm_gc_mark (SCM o) #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) +static void +finalize_smob (GC_PTR ptr, GC_PTR data) { SCM smob; size_t (* free_smob) (SCM); - smob = PTR2SCM (ptr); + smob = SCM_PACK_POINTER (ptr); #if 0 printf ("finalizing SMOB %p (smobnum: %u)\n", ptr, SCM_SMOBNUM (smob)); @@ -599,6 +576,73 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data) free_smob (smob); } +/* 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 (scm_t_bits tc, scm_t_bits data) +{ + scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); + SCM ret; + + /* Use the smob_gc_kind if needed to allow the mark procedure to + run. Since the marker only deals with double cells, that case + allocates a double cell. We leave words 2 and 3 to there initial + values, which is 0. */ + if (scm_smobs [smobnum].mark) + ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); + else + ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell))); + + SCM_SET_CELL_WORD_1 (ret, data); + SCM_SET_CELL_WORD_0 (ret, tc); + + if (scm_smobs[smobnum].free) + { + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalizer_data; + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), + finalize_smob, NULL, + &prev_finalizer, &prev_finalizer_data); + } + + return ret; +} + +/* 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_double_smob (scm_t_bits tc, scm_t_bits data1, + scm_t_bits data2, scm_t_bits data3) +{ + scm_t_bits smobnum = SCM_TC2SMOBNUM (tc); + SCM ret; + + /* Use the smob_gc_kind if needed to allow the mark procedure to + run. */ + if (scm_smobs [smobnum].mark) + ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); + else + ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell))); + + SCM_SET_CELL_WORD_3 (ret, data3); + SCM_SET_CELL_WORD_2 (ret, data2); + SCM_SET_CELL_WORD_1 (ret, data1); + SCM_SET_CELL_WORD_0 (ret, tc); + + if (scm_smobs[smobnum].free) + { + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalizer_data; + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret), + finalize_smob, NULL, + &prev_finalizer, &prev_finalizer_data); + } + + return ret; +} + void scm_smob_prehistory () @@ -625,7 +669,7 @@ scm_smob_prehistory () scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F; } - tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); + tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); } /* |