[],
[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,
chars.c continuations.c convert.c debug.c deprecation.c \
deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
- futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
- gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c \
+ futures.c gc.c gc-malloc.c \
+ gdbint.c gh_data.c gh_eval.c gh_funcs.c \
gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \
guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \
- extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \
- gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x \
+ extensions.x feature.x fluids.x fports.x futures.x gc.x \
+ goops.x gsubr.x guardians.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
environments.doc eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
- gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \
- gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc \
+ gc.doc goops.doc gsubr.doc \
+ gc-malloc.doc guardians.doc hash.doc hashtab.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
+ /* FIXME: What to do here? */
+#if 0
SCM *statep, *fluidp;
/* Scan all fluids and deallocate the unmarked ones.
}
}
+#endif
return NULL;
}
scm_realloc (void *mem, size_t size)
{
void *ptr;
- scm_t_sweep_statistics sweep_stats;
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
return ptr;
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
+ /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
+ GC_gcollect ();
- scm_i_sweep_all_segments ("realloc", &sweep_stats);
-
- SCM_SYSCALL (ptr = realloc (mem, size));
- if (ptr)
- {
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
- return ptr;
- }
-
- scm_i_gc ("realloc");
- scm_i_sweep_all_segments ("realloc", &sweep_stats);
-
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
-
SCM_SYSCALL (ptr = realloc (mem, size));
if (ptr)
return ptr;
SCM_SYSCALL (ptr = calloc (sz, 1));
if (ptr)
return ptr;
-
+
ptr = scm_realloc (NULL, sz);
memset (ptr, 0x0, sz);
return ptr;
return scm_strndup (str, strlen (str));
}
-static void
-decrease_mtrigger (size_t size, const char * what)
-{
- scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
-
- if (size > scm_mallocated)
- {
- fprintf (stderr, "`scm_mallocated' underflow. This means that more "
- "memory was unregistered\n"
- "via `scm_gc_unregister_collectable_memory ()' than "
- "registered.\n");
- abort ();
- }
-
- scm_mallocated -= size;
- scm_gc_malloc_collected += size;
- scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
-}
-
-static void
-increase_mtrigger (size_t size, const char *what)
-{
- size_t mallocated = 0;
- int overflow = 0, triggered = 0;
-
- scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
- if (ULONG_MAX - size < scm_mallocated)
- overflow = 1;
- else
- {
- scm_mallocated += size;
- mallocated = scm_mallocated;
- if (scm_mallocated > scm_mtrigger)
- triggered = 1;
- }
- scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
- if (overflow)
- scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
-
- /*
- A program that uses a lot of malloced collectable memory (vectors,
- strings), will use a lot of memory off the cell-heap; it needs to
- do GC more often (before cells are exhausted), otherwise swapping
- and malloc management will tie it down.
- */
- if (triggered)
- {
- unsigned long prev_alloced;
- float yield;
- scm_t_sweep_statistics sweep_stats;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
-
- prev_alloced = mallocated;
- scm_i_gc (what);
- scm_i_sweep_all_segments ("mtrigger", &sweep_stats);
-
- yield = (((float) prev_alloced - (float) scm_mallocated)
- / (float) prev_alloced);
-
- scm_gc_malloc_yield_percentage = (int) (100 * yield);
-
-#ifdef DEBUGINFO
- fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d",
- prev_alloced,
- scm_mallocated,
- 100.0 * yield,
- scm_i_minyield_malloc);
-#endif
-
- if (yield < scm_i_minyield_malloc / 100.0)
- {
- /*
- We make the trigger a little larger, even; If you have a
- program that builds up a lot of data in strings, then the
- desired yield will never be satisfied.
-
- Instead of getting bogged down, we let the mtrigger grow
- strongly with it.
- */
- float no_overflow_trigger = scm_mallocated * 110.0;
-
- no_overflow_trigger /= (float) (100.0 - scm_i_minyield_malloc);
-
-
- if (no_overflow_trigger >= (float) ULONG_MAX)
- scm_mtrigger = ULONG_MAX;
- else
- scm_mtrigger = (unsigned long) no_overflow_trigger;
-
-#ifdef DEBUGINFO
- fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
- scm_mtrigger);
-#endif
- }
-
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
- }
-}
void
scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
{
- increase_mtrigger (size, what);
#ifdef GUILE_DEBUG_MALLOC
if (mem)
- scm_malloc_register (mem, what);
+ scm_malloc_register (mem);
#endif
+ fprintf (stderr, "%s: nothing done\n", __FUNCTION__); /* FIXME: What to do? */
}
void
scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
{
- decrease_mtrigger (size, what);
#ifdef GUILE_DEBUG_MALLOC
if (mem)
scm_malloc_unregister (mem);
to write it the program is killed with signal 11. --hwn
*/
- void *ptr = scm_malloc (size);
- scm_gc_register_collectable_memory (ptr, size, what);
+ void *ptr = GC_MALLOC (size);
return ptr;
}
{
void *ptr;
- /* XXX - see scm_gc_malloc. */
-
-
- /*
- scm_realloc() may invalidate the block pointed to by WHERE, eg. by
- unmapping it from memory or altering the contents. Since
- increase_mtrigger() might trigger a GC that would scan
- MEM, it is crucial that this call precedes realloc().
- */
-
- decrease_mtrigger (old_size, what);
- increase_mtrigger (new_size, what);
-
- ptr = scm_realloc (mem, new_size);
+ ptr = GC_REALLOC (mem, new_size);
#ifdef GUILE_DEBUG_MALLOC
if (mem)
scm_malloc_reregister (mem, ptr, what);
#endif
-
+
return ptr;
}
scm_gc_free (void *mem, size_t size, const char *what)
{
scm_gc_unregister_collectable_memory (mem, size, what);
- free (mem);
+ GC_FREE (mem);
}
char *
scm_gc_strndup (const char *str, size_t n, const char *what)
{
- char *dst = scm_gc_malloc (n+1, what);
+ char *dst = GC_MALLOC (n+1);
memcpy (dst, str, n);
dst[n] = 0;
return dst;
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
\f
+/* Hooks. */
+scm_t_c_hook scm_before_gc_c_hook;
+scm_t_c_hook scm_before_mark_c_hook;
+scm_t_c_hook scm_before_sweep_c_hook;
+scm_t_c_hook scm_after_sweep_c_hook;
+scm_t_c_hook scm_after_gc_c_hook;
/* scm_mtrigger
SCM tab = scm_make_hash_table (scm_from_int (57));
SCM alist;
- scm_i_all_segments_statistics (tab);
-
alist
= scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
double local_scm_gc_cells_marked;
SCM answer;
unsigned long *bounds = 0;
- int table_size = scm_i_heap_segment_table_size;
SCM_CRITICAL_SECTION_START;
/*
temporarily store the numbers, so as not to cause GC.
*/
-
+#if 0
bounds = malloc (sizeof (unsigned long) * table_size * 2);
if (!bounds)
abort();
- for (i = table_size; i--; )
- {
- bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0];
- bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1];
- }
-
+#endif
+ return SCM_EOL; /* FIXME */
+#if 0
/* Below, we cons to produce the resulting list. We want a snapshot of
* the heap situation before consing.
*/
local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated;
- local_scm_heap_size = SCM_HEAP_SIZE;
+ local_scm_heap_size = 0; /* SCM_HEAP_SIZE; */ /* FIXME */
local_scm_cells_allocated = scm_cells_allocated;
free (bounds);
return answer;
+#endif
}
#undef FUNC_NAME
-static void
-gc_start_stats (const char *what SCM_UNUSED)
-{
- t_before_gc = scm_c_get_internal_run_time ();
-
- scm_gc_malloc_collected = 0;
- scm_gc_ports_collected = 0;
-}
-
-static void
-gc_end_stats (scm_t_sweep_statistics sweep_stats)
-{
- unsigned long t = scm_c_get_internal_run_time ();
- scm_gc_time_taken += (t - t_before_gc);
- /*
- 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_cells_marked_acc += (double) sweep_stats.swept
- - (double) scm_gc_cells_collected;
- scm_gc_cells_swept_acc += (double) sweep_stats.swept;
-
- scm_gc_cell_yield_percentage = (sweep_stats.collected * 100) / SCM_HEAP_SIZE;
-
- scm_gc_cells_swept = sweep_stats.swept;
- scm_gc_cells_collected_1 = scm_gc_cells_collected;
- scm_gc_cells_collected = sweep_stats.collected;
- scm_cells_allocated -= sweep_stats.collected;
-
- ++scm_gc_times;
-}
SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
}
#undef FUNC_NAME
-
-\f
-
-/* The master is global and common while the freelist will be
- * individual for each thread.
- */
-
-SCM
-scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
-{
- SCM cell;
- int did_gc = 0;
- scm_t_sweep_statistics sweep_stats;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
- scm_gc_running_p = 1;
-
- *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
- scm_cells_allocated -= sweep_stats.collected;
-
- if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist))
- {
- freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
- *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
- scm_cells_allocated -= sweep_stats.collected;
- }
-
- if (*free_cells == SCM_EOL)
- {
- /*
- with the advent of lazy sweep, GC yield is only known just
- before doing the GC.
- */
- scm_i_adjust_min_yield (freelist, sweep_stats);
-
- /*
- out of fresh cells. Try to get some new ones.
- */
-
- did_gc = 1;
- scm_i_gc ("cells");
-
- *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
- scm_cells_allocated -= sweep_stats.collected;
- }
-
- if (*free_cells == SCM_EOL)
- {
- /*
- failed getting new cells. Get new juice or die.
- */
- freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
- *free_cells = scm_i_sweep_some_segments (freelist, &sweep_stats);
- scm_cells_allocated -= sweep_stats.collected;
- }
-
- if (*free_cells == SCM_EOL)
- abort ();
-
- cell = *free_cells;
-
- *free_cells = SCM_FREE_CELL_CDR (cell);
-
- scm_gc_running_p = 0;
- scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
-
- if (did_gc)
- scm_c_hook_run (&scm_after_gc_c_hook, 0);
-
- return cell;
-}
-
-
-scm_t_c_hook scm_before_gc_c_hook;
-scm_t_c_hook scm_before_mark_c_hook;
-scm_t_c_hook scm_before_sweep_c_hook;
-scm_t_c_hook scm_after_sweep_c_hook;
-scm_t_c_hook scm_after_gc_c_hook;
-
-/* Must be called while holding scm_i_sweep_mutex.
- */
-
void
scm_i_gc (const char *what)
{
- scm_t_sweep_statistics sweep_stats;
-
- scm_i_thread_put_to_sleep ();
-
- scm_c_hook_run (&scm_before_gc_c_hook, 0);
-
-#ifdef DEBUGINFO
- fprintf (stderr,"gc reason %s\n", what);
-
- fprintf (stderr,
- scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist))
- ? "*"
- : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m"));
-#endif
-
- gc_start_stats (what);
-
- /*
- Set freelists to NULL so scm_cons() always triggers gc, causing
- the assertion above to fail.
- */
- *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
- *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
-
- /*
- Let's finish the sweep. The conservative GC might point into the
- garbage, and marking that would create a mess.
- */
- scm_i_sweep_all_segments ("GC", &sweep_stats);
-
- /* Invariant: the number of cells collected (i.e., freed) must always be
- lower than or equal to the number of cells "swept" (i.e., visited). */
- assert (sweep_stats.collected <= sweep_stats.swept);
-
- if (scm_mallocated < scm_i_deprecated_memory_return)
- {
- /* The byte count of allocated objects has underflowed. This is
- probably because you forgot to report the sizes of objects you
- have allocated, by calling scm_done_malloc or some such. When
- the GC freed them, it subtracted their size from
- scm_mallocated, which underflowed. */
- fprintf (stderr,
- "scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
- "This is probably because the GC hasn't been correctly informed\n"
- "about object sizes\n");
- abort ();
- }
- scm_mallocated -= scm_i_deprecated_memory_return;
-
-
- /* Mark */
-
- scm_c_hook_run (&scm_before_mark_c_hook, 0);
- scm_mark_all ();
- scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc);
-
- /* Sweep
-
- TODO: the after_sweep hook should probably be moved to just before
- the mark, since that's where the sweep is finished in lazy
- sweeping.
-
- MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
- original meaning implied at least two things: that it would be
- called when
-
- 1. the freelist is re-initialized (no evaluation possible, though)
-
- and
-
- 2. the heap is "fresh"
- (it is well-defined what data is used and what is not)
-
- Neither of these conditions would hold just before the mark phase.
-
- Of course, the lazy sweeping has muddled the distinction between
- scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
- there were no difference, it would still be useful to have two
- distinct classes of hook functions since this can prevent some
- bad interference when several modules adds gc hooks.
- */
-
- scm_c_hook_run (&scm_before_sweep_c_hook, 0);
- scm_gc_sweep ();
- scm_c_hook_run (&scm_after_sweep_c_hook, 0);
-
- gc_end_stats (sweep_stats);
-
- scm_i_thread_wake_up ();
-
- /*
- For debugging purposes, you could do
- scm_i_sweep_all_segments("debug"), but then the remains of the
- cell aren't left to analyse.
- */
+ GC_gcollect ();
}
while (j)
scm_sys_protects[--j] = SCM_BOOL_F;
- scm_gc_init_freelist();
- scm_gc_init_malloc ();
-
j = SCM_HEAP_SEG_SIZE;
-
/* Initialise the list of ports. */
scm_i_port_table = (scm_t_port **)
malloc (sizeof (scm_t_port *) * scm_i_port_table_room);
return NULL;
}
+char const *
+scm_i_tag_name (scm_t_bits tag)
+{
+ if (tag >= 255)
+ {
+ if (tag == scm_tc_free_cell)
+ return "free cell";
+
+ {
+ int k = 0xff & (tag >> 8);
+ return (scm_smobs[k].name);
+ }
+ }
+
+ switch (tag) /* 7 bits */
+ {
+ case scm_tcs_struct:
+ return "struct";
+ case scm_tcs_cons_imcar:
+ return "cons (immediate car)";
+ case scm_tcs_cons_nimcar:
+ return "cons (non-immediate car)";
+ case scm_tcs_closures:
+ return "closures";
+ case scm_tc7_pws:
+ return "pws";
+ case scm_tc7_wvect:
+ return "weak vector";
+ case scm_tc7_vector:
+ return "vector";
+#ifdef CCLO
+ case scm_tc7_cclo:
+ return "compiled closure";
+#endif
+ case scm_tc7_number:
+ switch (tag)
+ {
+ case scm_tc16_real:
+ return "real";
+ break;
+ case scm_tc16_big:
+ return "bignum";
+ break;
+ case scm_tc16_complex:
+ return "complex number";
+ break;
+ case scm_tc16_fraction:
+ return "fraction";
+ break;
+ }
+ break;
+ case scm_tc7_string:
+ return "string";
+ break;
+ case scm_tc7_stringbuf:
+ return "string buffer";
+ break;
+ case scm_tc7_symbol:
+ return "symbol";
+ break;
+ case scm_tc7_variable:
+ return "variable";
+ break;
+ case scm_tcs_subrs:
+ return "subrs";
+ break;
+ case scm_tc7_port:
+ return "port";
+ break;
+ case scm_tc7_smob:
+ return "smob"; /* should not occur. */
+ break;
+ }
+
+ return NULL;
+}
+
+
+/*
+ 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)
+{
+}
+
+\f
void
scm_init_gc ()
{
- scm_gc_init_mark ();
+ GC_init ();
scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
scm_c_define ("after-gc-hook", scm_after_gc_hook);
scm_gc_sweep (void)
#define FUNC_NAME "scm_gc_sweep"
{
- scm_i_deprecated_memory_return = 0;
-
- scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist);
- scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2);
-
- /*
- NOTHING HERE: LAZY SWEEPING !
- */
- scm_i_reset_segments ();
-
- *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
- *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
-
- /* Invalidate the freelists of other threads. */
- scm_i_thread_invalidate_freelists ();
+ /* FIXME */
+ fprintf (stderr, "%s: doing nothing\n", __FUNCTION__);
}
#undef FUNC_NAME
#include "libguile/threads.h"
\f
-
-/* Cell allocation and garbage collection work rouhgly in the
- following manner:
-
- Each thread has a 'freelist', which is a list of available cells.
- (It actually has two freelists, one for single cells and one for
- double cells. Everything works analogous for double cells.)
-
- When a thread wants to allocate a cell and the freelist is empty,
- it refers to a global list of unswept 'cards'. A card is a small
- block of cells that are contigous in memory, together with the
- corresponding mark bits. A unswept card is one where the mark bits
- are set for cells that have been in use during the last global mark
- phase, but the unmarked cells of the card have not been scanned and
- freed yet.
-
- The thread takes one of the unswept cards and sweeps it, thereby
- building a new freelist that it then uses. Sweeping a card will
- call the smob free functions of unmarked cells, for example, and
- thus, these free functions can run at any time, in any thread.
-
- When there are no more unswept cards available, the thread performs
- a global garbage collection. For this, all other threads are
- stopped. A global mark is performed and all cards are put into the
- global list of unswept cards. Whennecessary, new cards are
- allocated and initialized at this time. The other threads are then
- started again.
-*/
-
typedef struct scm_t_cell
{
SCM word_0;
SCM word_1;
} scm_t_cell;
-/*
- CARDS
-
- A card is a small `page' of memory; it will be the unit for lazy
- sweeping, generations, etc. The first cell of a card contains a
- pointer to the mark bitvector, so that we can find the bitvector
- efficiently: we knock off some lowerorder bits.
-
- The size on a 32 bit machine is 256 cells = 2kb. The card [XXX]
-*/
-
-
-
/* Cray machines have pointers that are incremented once for each
* word, rather than each byte, the 3 most significant bits encode the
* byte within the word. The following macros deal with this by
#endif /* def _UNICOS */
-#define SCM_GC_CARD_N_HEADER_CELLS 1
-#define SCM_GC_CARD_N_CELLS 256
-#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
-
-#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
-#define SCM_GC_SET_CARD_BVEC(card, bvec) \
- ((card)->word_0 = (SCM) (bvec))
-#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
-#define SCM_GC_SET_CARD_FLAGS(card, flags) \
- ((card)->word_1 = (SCM) (flags))
-
-#define SCM_GC_GET_CARD_FLAG(card, shift) \
- (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
-#define SCM_GC_SET_CARD_FLAG(card, shift) \
- (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
-#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
- (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
-
-/*
- Remove card flags. They hamper lazy initialization, and aren't used
- anyways.
- */
-
-/* card addressing. for efficiency, cards are *always* aligned to
- SCM_GC_CARD_SIZE. */
-
-#define SCM_GC_CARD_SIZE_MASK (SCM_GC_SIZEOF_CARD-1)
-#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
-
-#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
-#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
-#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
-#define SCM_GC_SET_CELL_BVEC(x, bvec) SCM_GC_SET_CARD_BVEC (SCM_GC_CELL_CARD (x), bvec)
-#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
-
-#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
-#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
-
-/* low level bit banging aids */
-typedef unsigned long scm_t_c_bvec_long;
-
-#if (SCM_SIZEOF_UNSIGNED_LONG == 8)
-# define SCM_C_BVEC_LONG_BITS 64
-# define SCM_C_BVEC_OFFSET_SHIFT 6
-# define SCM_C_BVEC_POS_MASK 63
-# define SCM_CELL_SIZE_SHIFT 4
-#else
-# define SCM_C_BVEC_LONG_BITS 32
-# define SCM_C_BVEC_OFFSET_SHIFT 5
-# define SCM_C_BVEC_POS_MASK 31
-# define SCM_CELL_SIZE_SHIFT 3
-#endif
-
-#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT)
-
-#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
-#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
-#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
-
-/* testing and changing GC marks */
-#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
-#define SCM_SET_GC_MARK(x) SCM_GC_CELL_SET_BIT (x)
-#define SCM_CLEAR_GC_MARK(x) SCM_GC_CELL_CLEAR_BIT (x)
/* Low level cell data accessing macros. These macros should only be used
* from within code related to garbage collection issues, since they will
static void
unmark_port (SCM port)
{
+#if 0
SCM stream, string;
port_mark_p = SCM_GC_MARK_P (port);
SCM_CLEAR_GC_MARK (port);
string = SCM_CDR (stream);
string_mark_p = SCM_GC_MARK_P (string);
SCM_CLEAR_GC_MARK (string);
+#else
+ abort (); /* FIXME */
+#endif
}
static void
remark_port (SCM port)
{
+#if 0
SCM stream = SCM_PACK (SCM_STREAM (port));
SCM string = SCM_CDR (stream);
if (string_mark_p)
SCM_SET_GC_MARK (stream);
if (port_mark_p)
SCM_SET_GC_MARK (port);
+#else
+ abort (); /* FIXME */
+#endif
}
int
gdb_maybe_valid_type_p (SCM value)
{
- return SCM_IMP (value) || scm_in_heap_p (value);
+ return SCM_IMP (value); /* || scm_in_heap_p (value); */ /* FIXME: What to
+ do? */
}
int
gdb_read (char *str)
{
+#if 0
SCM ans;
int status = 0;
RESET_STRING;
/* Need to be restrictive about what to read? */
- if (SCM_GC_P)
+ if (1) /* (SCM_GC_P) */ /* FIXME */
{
char *p;
for (p = str; *p != '\0'; ++p)
remark_port (gdb_input_port);
SCM_END_FOREIGN_BLOCK;
return status;
+#else
+ abort ();
+#endif
}
*/
\f
+#if 0 /* FIXME: Not re-implemented for Boehm's GC. */
/* This is an implementation of guardians as described in
* R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
c-file-style: "gnu"
End:
*/
+
+#endif
return 1;
}
-#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
+/* FIXME */
+#define UNMARKED_CELL_P(x) 0 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) */
/* keep track of hash tables that need to shrink after scan */
static SCM to_rehash = SCM_EOL;
void
scm_i_scan_weak_hashtables ()
{
+#if 0 /* FIXME */
SCM *next = &weak_hashtables;
SCM h = *next;
while (!scm_is_null (h))
}
}
}
+#endif
}
static void *
scm_init_vectors ();
scm_init_version ();
scm_init_weaks ();
- scm_init_guardians ();
+/* scm_init_guardians (); */
scm_init_vports ();
scm_init_eval ();
scm_init_evalext ();
#include "libguile/pairs.h"
+#include <gc/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);
#endif
SCM_C_INLINE
#endif
+
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM z;
- SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
+ SCM cell = SCM_PACK ((scm_t_bits) (GC_malloc (sizeof (scm_t_cell))));
- if (scm_is_null (*freelist))
- z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
- else
- {
- z = *freelist;
- *freelist = SCM_FREE_CELL_CDR (*freelist);
- }
-
- /*
- We update scm_cells_allocated from this function. If we don't
- update this explicitly, we will have to walk a freelist somewhere
- later on, which seems a lot more expensive.
- */
- scm_cells_allocated += 1;
-
-#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();
- }
- }
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
- /*
- Always set mark. Otherwise cells that are alloced before
- scm_debug_cell_accesses_p is toggled seem invalid.
- */
- SCM_SET_GC_MARK (z);
-
- /*
- TODO: figure out if this use of mark bits is valid with
- threading. What if another thread is doing GC at this point
- ... ?
- */
-
-#endif
-
-
- /* 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);
-
-#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
scm_t_bits ccr, scm_t_bits cdr)
{
SCM z;
- SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2);
-
- if (scm_is_null (*freelist))
- z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist);
- else
- {
- z = *freelist;
- *freelist = SCM_FREE_CELL_CDR (*freelist);
- }
-
- scm_cells_allocated += 2;
+ z = SCM_PACK ((scm_t_bits) (GC_malloc (2 * 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
SCM_GC_SET_CELL_WORD (z, 3, cdr);
SCM_GC_SET_CELL_WORD (z, 0, car);
-#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (scm_debug_cell_accesses_p)
- {
- if (SCM_GC_MARK_P (z))
- {
- fprintf(stderr,
- "scm_double_cell tried to allocate a marked cell.\n");
- abort();
- }
- }
-
- /* see above. */
- SCM_SET_GC_MARK (z);
-
-#endif
-
/* When this function is inlined, it's possible that the last
SCM_GC_SET_CELL_WORD above will be adjacent to a following
initialization of z. E.g., it occurred in scm_make_real. GCC
{
scm_puts ("#<unknown-", port);
scm_puts (hdr, port);
- if (scm_in_heap_p (ptr))
+ if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
scm_puts (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
typedef enum { return_on_error, abort_on_error } policy_on_error;
-/* gc-freelist*/
-
-/*
- FREELIST:
-
- A struct holding GC statistics on a particular type of cells.
-*/
-typedef struct scm_t_cell_type_statistics {
-
- /*
- heap segment where the last cell was allocated
- */
- int heap_segment_idx;
-
- /* minimum yield on this list in order not to grow the heap
- */
- long min_yield;
-
- /* defines min_yield as percent of total heap size
- */
- int min_yield_fraction;
-
- /* number of cells per object on this list */
- int span;
-
- /* number of collected cells during last GC */
- unsigned long collected;
-
- /* number of collected cells during penultimate GC */
- unsigned long collected_1;
-
- /* total number of cells in heap segments
- * belonging to this list.
- */
- unsigned long heap_size;
-
-
-} scm_t_cell_type_statistics;
-
-
-/* Sweep statistics. */
-typedef struct scm_sweep_statistics
-{
- /* Number of cells "swept", i.e., visited during the sweep operation. */
- unsigned swept;
-
- /* Number of cells collected during the sweep operation. This number must
- alsways be lower than or equal to SWEPT. */
- unsigned collected;
-} scm_t_sweep_statistics;
-
-#define scm_i_sweep_statistics_init(_stats) \
- do \
- { \
- (_stats)->swept = (_stats)->collected = 0; \
- } \
- while (0)
-
-#define scm_i_sweep_statistics_sum(_sum, _addition) \
- do \
- { \
- (_sum)->swept += (_addition).swept; \
- (_sum)->collected += (_addition).collected; \
- } \
- while (0)
-
-
-\f
-extern scm_t_cell_type_statistics scm_i_master_freelist;
-extern scm_t_cell_type_statistics scm_i_master_freelist2;
-extern unsigned long scm_gc_cells_collected_1;
-
-void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist,
- scm_t_sweep_statistics sweep_stats);
-void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist);
-int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist);
-
-
-#define SCM_HEAP_SIZE \
- (scm_i_master_freelist.heap_size + scm_i_master_freelist2.heap_size)
-
#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
void scm_mark_all (void);
-
-/*
-gc-segment:
-*/
-
-
-
-
-/*
-
- 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;
-
-
-int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,scm_t_heap_segment*);
-int scm_i_sweep_card (scm_t_cell * card, SCM *free_list, scm_t_heap_segment*);
-void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg);
char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
-int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested);
-int scm_i_segment_card_count (scm_t_heap_segment * seg);
-int scm_i_segment_cell_count (scm_t_heap_segment * seg);
-
-void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
-scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
-SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats);
-void scm_i_sweep_segment (scm_t_heap_segment *seg,
- scm_t_sweep_statistics *sweep_stats);
-
-void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab);
-
-
-int scm_i_insert_segment (scm_t_heap_segment * seg);
-long int scm_i_find_heap_segment_containing_object (SCM obj);
-int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error);
-void scm_i_clear_mark_space (void);
-void scm_i_sweep_segments (void);
-SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl,
- scm_t_sweep_statistics *sweep_stats);
-void scm_i_reset_segments (void);
-void scm_i_sweep_all_segments (char const *reason,
- scm_t_sweep_statistics *sweep_stats);
-SCM scm_i_all_segments_statistics (SCM hashtab);
-void scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist);
extern long int scm_i_deprecated_memory_return;
return 0;
}
+
+/* During collection, this accumulates structures which are to be freed.
+ */
+SCM scm_i_structs_to_free;
+
static void *
scm_free_structs (void *dummy1 SCM_UNUSED,
void *dummy2 SCM_UNUSED,
void *dummy3 SCM_UNUSED)
{
+#if 0
SCM newchain = scm_i_structs_to_free;
do
{
}
while (!scm_is_null (newchain));
return 0;
+#endif
}
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
}
#undef FUNC_NAME
-#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
+#define UNMARKED_CELL_P(x) 1 /* (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) *//*
+ FIXME */
static SCM weak_vectors;
static void
scm_i_remove_weaks (SCM w)
{
+ return; /* FIXME */
+#if 0
SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
size_t n = SCM_I_WVECT_LENGTH (w);
size_t i;
#endif
SCM_I_SET_WVECT_DELTA (w, delta);
}
+#endif
}
void
HCoop / bpt / guile.git / commitdiff