diff options
-rw-r--r-- | libguile/gc.c | 92 | ||||
-rw-r--r-- | libguile/gc.h | 2 | ||||
-rw-r--r-- | libguile/guardians.c | 99 | ||||
-rw-r--r-- | libguile/smob.c | 13 | ||||
-rw-r--r-- | libguile/smob.h | 73 |
5 files changed, 134 insertions, 145 deletions
diff --git a/libguile/gc.c b/libguile/gc.c index 809e43d56..eba10038c 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -678,100 +678,8 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) int scm_i_terminating; -/* Finalizers. */ -static void -finalizer_trampoline (GC_PTR ptr, GC_PTR data) -{ - register SCM obj, finalizers; - - obj = PTR2SCM (ptr); - for (finalizers = PTR2SCM (data); - scm_is_pair (finalizers); - finalizers = SCM_CDR (finalizers)) - { - SCM (* finalize) (SCM, SCM); - SCM f = SCM_CAR (finalizers); - - finalize = (SCM (*) (SCM, SCM)) SCM2PTR (SCM_CAR (f)); - finalize (obj, SCM_CDR (f)); - } -} - - -/* Register FINALIZER as a finalization procedure for OBJ. FINALIZER will be - invoked when storage for OBJ is to be reclaimed and will be passed OBJ and - DATA. If ORDERED is non-zero, finalization will be "ordered" (see the - Boehm-GC doc for details). The function returns the data previously - registered for OBJ and FINALIZER, or `#f' if FINALIZER had not been - registered for OBJ before. - - Note that finalizers in general are known to be problematic. As such, - this function should only be used internally, and only to implement - functionalities that could not be implemented otherwise (e.g., guardians, - SMOB's free procedures). */ -SCM -scm_gc_register_finalizer (SCM obj, SCM (*finalizer) (SCM, SCM), - SCM data, int ordered) -{ - SCM prev_data = SCM_BOOL_F; - SCM finalization_data, finalization_subr; - GC_finalization_proc old_finalizer; - GC_PTR old_finalization_data; - - /* XXX: We don't use real `subrs' here because (i) it would add unnecessary - overhead and (ii) it creates a bootstrap problem (because SMOBs may rely - on this, and SMOBs are initialized before `gsubrs'). */ - finalization_subr = PTR2SCM (finalizer); - finalization_data = scm_cons (scm_cons (finalization_subr, data), - SCM_EOL); - if (ordered) - GC_REGISTER_FINALIZER (SCM2PTR (obj), finalizer_trampoline, - SCM2PTR (finalization_data), - &old_finalizer, &old_finalization_data); - else - GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalizer_trampoline, - SCM2PTR (finalization_data), - &old_finalizer, &old_finalization_data); - - if ((old_finalizer != NULL) && (old_finalizer != finalizer_trampoline)) - /* Inconsistent use of the mechanism. */ - abort (); - - if (old_finalization_data != NULL) - { - SCM f, prev, old_finalizer_list = PTR2SCM (old_finalization_data); - - if (!scm_is_pair (old_finalizer_list)) - abort (); - - /* Look for FINALIZER among the previously-installed finalizers. */ - for (f = old_finalizer_list, prev = SCM_BOOL_F; - scm_is_pair (f); - prev = f, f = SCM_CDR (f)) - { - if (SCM_SUBRF (SCM_CAR (f)) == finalizer) - break; - } - - if (scm_is_pair (f)) - { - prev_data = SCM_CDAR (f); - if (prev != SCM_BOOL_F) - SCM_SETCDR (prev, SCM_CDR (f)); - else - old_finalizer_list = SCM_CDR (old_finalizer_list); - } - - /* Concatenate the new finalizer list with the old one. */ - SCM_SETCDR (finalization_data, old_finalizer_list); - } - return prev_data; -} - - - /* MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC. */ diff --git a/libguile/gc.h b/libguile/gc.h index 671c15a30..117301272 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -235,8 +235,6 @@ SCM_API void *scm_gc_realloc (void *mem, size_t old_size, SCM_API void scm_gc_free (void *mem, size_t size, const char *what); SCM_API char *scm_gc_strdup (const char *str, const char *what); SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what); -SCM_API SCM scm_gc_register_finalizer (SCM obj, SCM (*finalizer) (SCM, SCM), - SCM data, int ordered); SCM_API void scm_remember_upto_here_1 (SCM obj); SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2); diff --git a/libguile/guardians.c b/libguile/guardians.c index b73da5467..649ed7820 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -96,15 +96,19 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) /* Handle finalization of OBJ which is guarded by the guardians listed in GUARDIAN_LIST. */ -static SCM -finalize_guarded (SCM obj, SCM guardian_list) +static void +finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data) { SCM cell_pool; + SCM obj, guardian_list, proxied_finalizer; + + obj = PTR2SCM (ptr); + guardian_list = SCM_CDR (PTR2SCM (finalizer_data)); + proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data)); #if 0 printf ("finalizing guarded %p (%u guardians)\n", - SCM2PTR (obj), scm_to_uint (scm_length (guardian_list))); - scm_write (guardian_list, scm_current_output_port ()); + ptr, scm_to_uint (scm_length (guardian_list))); #endif /* Preallocate a bunch of cells so that we can make sure that no garbage @@ -130,7 +134,7 @@ finalize_guarded (SCM obj, SCM guardian_list) cell_pool = SCM_CDR (cell_pool); /* Compute and update G's zombie list. */ - SCM_SETCAR (zombies, obj); + SCM_SETCAR (zombies, SCM_PACK (obj)); SCM_SETCDR (zombies, g->zombies); g->zombies = zombies; @@ -138,11 +142,30 @@ finalize_guarded (SCM obj, SCM guardian_list) g->zombies = zombies; } + if (proxied_finalizer != SCM_BOOL_F) + { + /* Re-register the finalizer that was in place before we installed this + one. */ + GC_finalization_proc finalizer, prev_finalizer; + GC_PTR finalizer_data, prev_finalizer_data; + + finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer)); + finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer)); + + if (finalizer == NULL) + abort (); + + GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data, + &prev_finalizer, &prev_finalizer_data); + #if 0 - printf ("end of finalize (%p)\n", SCM2PTR (obj)); + printf (" reinstalled proxied finalizer %p for %p\n", finalizer, ptr); #endif + } - return SCM_UNSPECIFIED; +#if 0 + printf ("end of finalize (%p)\n", ptr); +#endif } /* Add OBJ as a guarded object of GUARDIAN. */ @@ -151,22 +174,60 @@ scm_i_guard (SCM guardian, SCM obj) { t_guardian *g = GUARDIAN_DATA (guardian); - if (!SCM_IMP (obj)) + if (SCM_NIMP (obj)) { - /* Register a finalizer and pass a list of guardians interested in OBJ - as the ``client data'' argument. */ - SCM guardians_for_obj, prev_guardians_for_obj; + /* Register a finalizer and pass a pair as the ``client data'' + argument. The pair contains in its car `#f' or a pair describing a + ``proxied'' finalizer (see below); its cdr contains a list of + guardians interested in OBJ. + + A ``proxied'' finalizer is a finalizer that was registered for OBJ + before OBJ became guarded (e.g., a SMOB `free' function). We are + assuming here that finalizers are only used internally, either at + the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB') + or by this function. */ + GC_finalization_proc prev_finalizer; + GC_PTR prev_data; + SCM guardians_for_obj, finalizer_data; g->live++; guardians_for_obj = scm_cons (guardian, SCM_EOL); - - prev_guardians_for_obj = - scm_gc_register_finalizer (obj, finalize_guarded, - guardians_for_obj, 0); - - if (scm_is_pair (prev_guardians_for_obj)) - /* Concatenate the previous list of guardians for OBJ. */ - SCM_SETCDR (guardians_for_obj, prev_guardians_for_obj); + finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj); + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded, + SCM2PTR (finalizer_data), + &prev_finalizer, &prev_data); + + if (prev_finalizer == finalize_guarded) + { + /* OBJ is already guarded by another guardian: add GUARDIAN to its + list of guardians. */ + SCM prev_guardian_list, prev_finalizer_data; + + if (prev_data == NULL) + abort (); + + prev_finalizer_data = PTR2SCM (prev_data); + if (!scm_is_pair (prev_finalizer_data)) + abort (); + + prev_guardian_list = SCM_CDR (prev_finalizer_data); + SCM_SETCDR (guardians_for_obj, prev_guardian_list); + + /* Also copy information about proxied finalizers. */ + SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data)); + } + else if (prev_finalizer != NULL) + { + /* There was already a finalizer registered for OBJ so we will + ``proxy'' it, i.e., record it so that we can re-register it once + `finalize_guarded ()' has finished. */ + SCM proxied_finalizer; + + proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer), + PTR2SCM (prev_data)); + SCM_SETCAR (finalizer_data, proxied_finalizer); + } } } diff --git a/libguile/smob.c b/libguile/smob.c index bdeae2d93..de64d7f31 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -604,16 +604,21 @@ scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1, /* Finalize SMOB by calling its SMOB type's free function, if any. */ -SCM -scm_i_finalize_smob (SCM smob, SCM data) +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); - - return SCM_UNSPECIFIED; } diff --git a/libguile/smob.h b/libguile/smob.h index 780265f1e..05617933b 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -25,6 +25,9 @@ #include "libguile/__scm.h" #include "libguile/print.h" +#include <gc/gc.h> + + /* This is the internal representation of a smob type */ @@ -51,18 +54,25 @@ SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc, -#define SCM_NEWSMOB(z, tc, data) \ -do \ - { \ - register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ - z = (scm_smobs[_smobnum].mark \ - ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \ - 0, 0) \ - : scm_cell (tc, (scm_t_bits)(data))); \ - if (scm_smobs[_smobnum].free) \ - scm_gc_register_finalizer ((z), scm_i_finalize_smob, \ - SCM_BOOL_F, 0); \ - } \ +#define SCM_NEWSMOB(z, tc, data) \ +do \ + { \ + register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ + z = (scm_smobs[_smobnum].mark \ + ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \ + 0, 0) \ + : scm_cell (tc, (scm_t_bits)(data))); \ + if (scm_smobs[_smobnum].free) \ + { \ + GC_finalization_proc _prev_finalizer; \ + GC_PTR _prev_finalizer_data; \ + \ + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \ + NULL, \ + &_prev_finalizer, \ + &_prev_finalizer_data); \ + } \ + } \ while (0) #define SCM_RETURN_NEWSMOB(tc, data) \ @@ -80,21 +90,28 @@ while (0) return __SCM_smob_answer; \ } while (0) -#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ -do \ - { \ - register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ - z = (scm_smobs[_smobnum].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))); \ - if (scm_smobs[_smobnum].free) \ - scm_gc_register_finalizer ((z), scm_i_finalize_smob, \ - SCM_BOOL_F, 0); \ - } \ +#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ +do \ + { \ + register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ + z = (scm_smobs[_smobnum].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))); \ + if (scm_smobs[_smobnum].free) \ + { \ + GC_finalization_proc _prev_finalizer; \ + GC_PTR _prev_finalizer_data; \ + \ + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \ + NULL, \ + &_prev_finalizer, \ + &_prev_finalizer_data); \ + } \ + } \ while (0) #define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ @@ -139,7 +156,7 @@ SCM_API long scm_numsmob; SCM_API scm_smob_descriptor scm_smobs[]; SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data); -SCM_API SCM scm_i_finalize_smob (SCM smob, SCM data); +SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data); |