#--------------------------------------------------------------------
SCM_I_GSC_STACK_GROWS_UP=0
- AC_TRY_RUN(aux (l) unsigned long l;
- { int x; exit (l >= ((unsigned long)&x)); }
- main () { int q; aux((unsigned long)&q); },
- [SCM_I_GSC_STACK_GROWS_UP=1],
- [],
- [AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)])
+ AC_RUN_IFELSE([AC_LANG_SOURCE(
+ [AC_INCLUDES_DEFAULT
+ int
+ find_stack_direction ()
+ {
+ static char *addr = 0;
+ auto char dummy;
+ if (addr == 0)
+ {
+ addr = &dummy;
+ return find_stack_direction ();
+ }
+ else
+ return (&dummy > addr) ? 1 : -1;
+ }
+
+ int
+ main ()
+ {
+ return find_stack_direction () < 0;
+ }])],
+ [SCM_I_GSC_STACK_GROWS_UP=1],
+ [],
+ [AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)])
+#--------------------------------------------------------------------
+#
+# Boehm's GC library
+#
+#--------------------------------------------------------------------
+AC_CHECK_LIB([gc], [GC_collect_a_little],
+ [LIBS="-lgc $LIBS"],
+ [AC_MSG_ERROR([`libgc' (Boehm's GC library) not found.])])
+AC_CHECK_HEADER([gc/gc.h], [],
+ [AC_MSG_ERROR([`libgc' (Boehm's GC library) header files not found.])])
+
+
AC_CHECK_SIZEOF(float)
if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
AC_DEFINE(SCM_SINGLES, 1,
scm_cons (sym_cells_swept,
scm_from_double (local_scm_gc_cells_swept)),
scm_cons (sym_malloc_yield,
- scm_from_long(local_scm_gc_malloc_yield_percentage)),
+ scm_from_long (local_scm_gc_malloc_yield_percentage)),
scm_cons (sym_cell_yield,
scm_from_long (local_scm_gc_cell_yield_percentage)),
- scm_cons (sym_protected_objects,
- scm_from_ulong (local_protected_obj_count)),
scm_cons (sym_heap_segments, heap_segs),
+#endif
+ scm_cons (sym_heap_size, scm_from_size_t (heap_size)),
+ scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)),
+ scm_cons (sym_heap_total_allocated,
+ scm_from_size_t (total_bytes)),
+ scm_cons (sym_protected_objects,
+ scm_from_ulong (protected_obj_count)),
+ scm_cons (sym_times, scm_from_size_t (gc_times)),
SCM_UNDEFINED);
- SCM_CRITICAL_SECTION_END;
-
- free (bounds);
+
return answer;
}
#undef FUNC_NAME
-/*
- Update nice-to-know-statistics.
- */
-static void
-gc_end_stats ()
-{
- /* CELLS SWEPT is another word for the number of cells that were examined
- during GC. YIELD is the number that we cleaned out. MARKED is the number
- that weren't cleaned. */
- scm_gc_cell_yield_percentage = (scm_i_gc_sweep_stats.collected * 100) /
- (scm_i_master_freelist.heap_total_cells + scm_i_master_freelist2.heap_total_cells);
-
- scm_gc_cells_allocated_acc +=
- (double) scm_i_gc_sweep_stats.collected;
- scm_gc_cells_marked_acc += (double) scm_cells_allocated;
- scm_gc_cells_marked_conservatively_acc += (double) scm_i_find_heap_calls;
- scm_gc_cells_swept_acc += (double) scm_i_gc_sweep_stats.swept;
-
- ++scm_gc_times;
-}
+
-
SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
(SCM obj),
"Return an integer that for the lifetime of @var{obj} is uniquely\n"
#ifndef SCM_GC_H
#define SCM_GC_H
- /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
++/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
- if (scm_is_pair (it))
+
+ weak = IS_WEAK_THING (table);
+ alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
+ if (weak)
+ START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
+ it = assoc_fn (obj, alist, closure);
+ if (weak)
+ END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
+ if (scm_is_true (it))
return it;
+ else if (scm_is_true (it))
+ scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
/* When this is a weak hashtable, running the GC can change it.
SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
- SCM_API void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char*func_name);
+ SCM_INTERNAL void scm_i_rehash (SCM table, unsigned long (*hash_fn)(),
+ void *closure, const char *func_name);
-SCM_INTERNAL void scm_i_scan_weak_hashtables (void);
SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
#include "libguile/gc.h"
#include "libguile/threads.h"
#include "libguile/unif.h"
- #include "libguile/pairs.h"
+ #include "libguile/ports.h"
+ #include "libguile/error.h"
+
+
+ #ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+
+ /* GCC has `__inline__' in all modes, including strict ansi. GCC 4.3 and
+ above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
+ unless `-fgnu89-inline' is used. Here we want GNU "extern inline"
+ semantics, hence the `__gnu_inline__' attribute, in accordance with:
+ http://gcc.gnu.org/gcc-4.3/porting_to.html .
+
+ With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
+ semantics are not supported), but a warning is issued in C99 mode if
+ `__gnu_inline__' is not used.
+
+ Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
+ C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
+ inline" in that case. */
+
+ # if (defined __GNUC__) && (!(__APPLE_CC__ > 5400 && __STDC_VERSION__ >= 199901L))
+ # define SCM_C_USE_EXTERN_INLINE 1
+ # if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
+ # define SCM_C_EXTERN_INLINE \
+ extern __inline__ __attribute__ ((__gnu_inline__))
+ # else
+ # define SCM_C_EXTERN_INLINE extern __inline__
+ # endif
+ # elif (defined SCM_C_INLINE)
+ # define SCM_C_EXTERN_INLINE static SCM_C_INLINE
+ # endif
+
+ #endif /* SCM_INLINE_C_INCLUDING_INLINE_H */
+
+
+ #if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
+ || (defined SCM_C_USE_EXTERN_INLINE)
+ /* The `extern' declarations. They should only appear when used from
+ "inline.c", when `inline' is not supported at all or when "extern inline"
+ is used. */
+#include "libguile/boehm-gc.h"
+
+
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
extern unsigned scm_newcell2_count;
extern unsigned scm_newcell_count;
- #if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H
- /* definitely inlining */
- #ifdef __GNUC__
- extern
- #else
- static
- #endif
- SCM_C_INLINE
+
+ #ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+ SCM_C_EXTERN_INLINE
#endif
+
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM z;
- SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
-
- if (scm_is_null (*freelist))
- z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
- else
- {
- z = *freelist;
- *freelist = SCM_FREE_CELL_CDR (*freelist);
- }
-
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- {
- if (SCM_GC_MARK_P (z))
- {
- fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
- abort();
- }
- else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell)
- {
- fprintf(stderr, "cell from freelist is not a free cell.\n");
- abort();
- }
- }
-
-#if (SCM_DEBUG_MARKING_API == 0)
- /*
- Always set mark. Otherwise cells that are alloced before
- scm_debug_cell_accesses_p is toggled seem invalid.
- */
- SCM_SET_GC_MARK (z);
-#endif /* SCM_DEBUG_MARKING_API */
-
- /*
- TODO: figure out if this use of mark bits is valid with
- threading. What if another thread is doing GC at this point
- ... ?
- */
-#endif
+ 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 can actually run during this code, which it can't
- since the GC only runs when all other threads are stopped.
- */
- SCM_GC_SET_CELL_WORD (z, 1, cdr);
- SCM_GC_SET_CELL_WORD (z, 0, car);
+ /* 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
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_expensive_debug_cell_accesses_p )
- scm_i_expensive_validation_check (z);
-#endif
-
- return z;
+ return cell;
}
- #if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H
- /* definitely inlining */
- #ifdef __GNUC__
- extern
- #else
- static
- #endif
- SCM_C_INLINE
+ #ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+ SCM_C_EXTERN_INLINE
#endif
SCM
scm_double_cell (scm_t_bits car, scm_t_bits cbr,
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
}
+ #undef FUNC_NAME
-void
+void
scm_flush (SCM port)
{
long i = SCM_PTOBNUM (port);
void scm_mark_all (void);
-/*
-gc-segment:
-*/
--
- char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
-/*
-
- Cells are stored in a heap-segment: it is a contiguous chunk of
- memory, that associated with one freelist.
-*/
-typedef struct scm_t_heap_segment
-{
- /*
- {lower, upper} bounds of the segment
-
- The upper bound is also the start of the mark space.
- */
- scm_t_cell *bounds[2];
-
- /*
- If we ever decide to give it back, we could do it with this ptr.
-
- Note that giving back memory is not very useful; as long we don't
- touch a chunk of memory, the virtual memory system will keep it
- swapped out. We could simply forget about a block.
-
- (not that we do that, but anyway.)
- */
- void *malloced;
-
- scm_t_cell *next_free_card;
-
- /* address of the head-of-freelist pointer for this segment's cells.
- All segments usually point to the same one, scm_i_freelist. */
- scm_t_cell_type_statistics *freelist;
-
- /* number of cells per object in this segment */
- int span;
-
- /*
- Is this the first time that the cells are accessed?
- */
- int first_time;
-} scm_t_heap_segment;
-
-/*
- A table of segment records is kept that records the upper and
- lower extents of the segment; this is used during the conservative
- phase of gc to identify probably gc roots (because they point
- into valid segments at reasonable offsets).
-*/
-extern scm_t_heap_segment ** scm_i_heap_segment_table;
-extern size_t scm_i_heap_segment_table_size;
-
-
-SCM_INTERNAL int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
- scm_t_heap_segment*);
-SCM_INTERNAL int scm_i_sweep_card (scm_t_cell *card, SCM *free_list,
- scm_t_heap_segment *);
-SCM_INTERNAL int scm_i_card_marked_count (scm_t_cell *card, int span);
-SCM_INTERNAL void scm_i_card_statistics (scm_t_cell *p, SCM hashtab,
- scm_t_heap_segment *seg);
-SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
-
-SCM_INTERNAL int scm_i_initialize_heap_segment_data (scm_t_heap_segment *seg,
- size_t requested);
-
-SCM_INTERNAL int scm_i_segment_cells_per_card (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_segment_card_number (scm_t_heap_segment *seg,
- scm_t_cell *card);
-SCM_INTERNAL int scm_i_segment_card_count (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_segment_cell_count (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_heap_segment_marked_count (scm_t_heap_segment *seg);
-
-SCM_INTERNAL void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
-SCM_INTERNAL scm_t_heap_segment *
-scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
-SCM_INTERNAL SCM scm_i_sweep_for_freelist (scm_t_cell_type_statistics *seg);
-SCM_INTERNAL SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats,
- int threshold);
-SCM_INTERNAL void scm_i_sweep_segment (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats);
-
-SCM_INTERNAL void scm_i_heap_segment_statistics (scm_t_heap_segment *seg,
- SCM tab);
-
--
-SCM_INTERNAL int scm_i_insert_segment (scm_t_heap_segment *seg);
-SCM_INTERNAL int scm_i_find_heap_segment_containing_object (SCM obj);
-SCM_INTERNAL int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
- size_t length,
- policy_on_error);
-SCM_INTERNAL int scm_i_marked_count (void);
-SCM_INTERNAL void scm_i_clear_mark_space (void);
-SCM_INTERNAL void scm_i_sweep_segments (void);
-SCM_INTERNAL SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl,
- scm_t_sweep_statistics *sweep_stats);
-SCM_INTERNAL void scm_i_reset_segments (void);
-SCM_INTERNAL void scm_i_sweep_all_segments (char const *reason,
- scm_t_sweep_statistics *sweep_stats);
-SCM_INTERNAL SCM scm_i_all_segments_statistics (SCM hashtab);
-SCM_INTERNAL unsigned long *scm_i_segment_table_info(int *size);
--
extern long int scm_i_deprecated_memory_return;
-
+ extern long int scm_i_find_heap_calls;
/*
global init funcs.
--/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
++/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
\f
- #define _GNU_SOURCE
-
+#include "libguile/boehm-gc.h"
#include "libguile/_scm.h"
#if HAVE_UNISTD_H
/* XXX - check for errors. */
pipe (t->sleep_pipe);
scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
+ scm_i_pthread_mutex_init (&t->admin_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->canceled = 0;
t->exited = 0;
}
#undef FUNC_NAME
-
- \f
- /*** Fat 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
- asyncs) and we might want to add things that are nice for
- debugging.
- */
-
- typedef struct {
- scm_i_pthread_mutex_t lock;
- SCM owner;
- int level; /* how much the owner owns us.
- < 0 for non-recursive mutexes */
- SCM waiting; /* the threads waiting for this mutex. */
- } fat_mutex;
-
- #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
- #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
+ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a thread.")
+ #define FUNC_NAME s_scm_thread_p
+ {
+ return SCM_I_IS_THREAD(obj) ? SCM_BOOL_T : SCM_BOOL_F;
+ }
+ #undef FUNC_NAME
-static SCM
-fat_mutex_mark (SCM mx)
-{
- fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_gc_mark (m->owner);
- return m->waiting;
-}
static size_t
fat_mutex_free (SCM mx)
}
#undef FUNC_NAME
- #endif
-
- /*** Fat condition variables */
-
- typedef struct {
- scm_i_pthread_mutex_t lock;
- SCM waiting; /* the threads waiting for this condition. */
- } fat_cond;
-
- #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
- #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
+ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0,
+ (SCM mx),
+ "Returns @code{#t} if the mutex @var{mx} is locked.")
+ #define FUNC_NAME s_scm_mutex_locked_p
+ {
+ SCM_VALIDATE_MUTEX (1, mx);
+ return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F;
+ }
+ #undef FUNC_NAME
-static SCM
-fat_cond_mark (SCM cv)
-{
- fat_cond *c = SCM_CONDVAR_DATA (cv);
- return c->waiting;
-}
-
static size_t
fat_cond_free (SCM mx)
{
extern int scm_i_thread_go_to_sleep;
- void scm_i_thread_put_to_sleep (void);
- void scm_i_thread_wake_up (void);
- void scm_i_thread_invalidate_freelists (void);
+ SCM_INTERNAL void scm_i_thread_put_to_sleep (void);
+ SCM_INTERNAL void scm_i_thread_wake_up (void);
+ SCM_INTERNAL void scm_i_thread_invalidate_freelists (void);
void scm_i_thread_sleep_for_gc (void);
-SCM_INTERNAL void scm_threads_prehistory (SCM_STACKITEM *);
-SCM_INTERNAL void scm_threads_init_first_thread (void);
-SCM_INTERNAL void scm_threads_mark_stacks (void);
+void scm_threads_prehistory (SCM_STACKITEM *);
+void scm_threads_init_first_thread (void);
+
- SCM_API void scm_init_threads (void);
- SCM_API void scm_init_thread_procs (void);
- SCM_API void scm_init_threads_default_dynamic_state (void);
+ SCM_INTERNAL void scm_init_threads (void);
+ SCM_INTERNAL void scm_init_thread_procs (void);
+ SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
#define SCM_THREAD_SWITCHING_CODE \
#define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x))
#define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o)))
- SCM_API SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
- SCM_API SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);
-SCM_INTERNAL SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill);
++SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
++SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);
- SCM_API void scm_init_vectors (void);
+ SCM_INTERNAL void scm_init_vectors (void);
#endif /* SCM_VECTORS_H */
SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
- SCM_API SCM scm_init_weaks_builtins (void);
- SCM_API void scm_weaks_prehistory (void);
- SCM_API void scm_init_weaks (void);
-
- SCM_API void scm_i_init_weak_vectors_for_gc (void);
- SCM_API void scm_i_mark_weak_vector (SCM w);
- SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
- SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
+ SCM_INTERNAL SCM scm_init_weaks_builtins (void);
++SCM_INTERNAL void scm_weaks_prehistory (void);
+ SCM_INTERNAL void scm_init_weaks (void);
+
+ SCM_INTERNAL void scm_i_init_weak_vectors_for_gc (void);
+ SCM_INTERNAL void scm_i_mark_weak_vector (SCM w);
+ SCM_INTERNAL int scm_i_mark_weak_vectors_non_weaks (void);
+ SCM_INTERNAL void scm_i_remove_weaks_from_weak_vectors (void);
#endif /* SCM_WEAKS_H */
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
- ;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
-;;;; Copyright (C) 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
++;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(with-test-prefix "gc"
(pass-if "Unused modules are removed"
- (let*
- ((dummy (gc))
- (last-count (cdr (assoc
- "eval-closure" (gc-live-object-stats)))))
+ ;; FIXME: This test fails because of the circular reference
+ ;; created by `make-module' between the module itself and its
+ ;; standard eval closure.
+ (let* ((guard (make-guardian))
+ (total 1000))
- (for-each (lambda (x) (make-module)) (iota 1000))
+ (for-each (lambda (x) (guard (make-module))) (iota total))
+
+ ;; XXX: This hack aims to clean up the stack to make sure we
+ ;; don't leave a reference to one of the modules we created. It
+ ;; proved to be useful on SPARC:
+ ;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
+ (let cleanup ((i 10))
+ (and (> i 0)
+ (begin (cleanup (1- i)) i)))
+
(gc)
(gc) ;; twice: have to kill the weak vectors.
- (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats)))))
- ))
+ (= (length (filter (lambda (x)
+ (eq? x #t))
+ (map (lambda (x) (and (guard) #t))
+ (iota total))))
+ total))))
HCoop / bpt / guile.git / commitdiff