-/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
\f
#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/stime.h"
#include "libguile/tags.h"
#include "libguile/validate.h"
+#include "libguile/deprecation.h"
#include "libguile/gc.h"
#ifdef GUILE_DEBUG_MALLOC
#if (SCM_DEBUG_CELL_ACCESSES == 1)
-unsigned int scm_debug_cell_accesses_p = 0;
+scm_t_bits scm_tc16_allocated;
+
+/* Set this to != 0 if every cell that is accessed shall be checked:
+ */
+unsigned int scm_debug_cell_accesses_p = 1;
+
+/* Set this to 0 if no additional gc's shall be performed, otherwise set it to
+ * the number of cell accesses after which a gc shall be called.
+ */
+static unsigned int debug_cells_gc_interval = 0;
+
+
+/* If an allocated cell is detected during garbage collection, this means that
+ * some code has just obtained the object but was preempted before the
+ * initialization of the object was completed. This meanst that some entries
+ * of the allocated cell may already contain SCM objects. Therefore,
+ * allocated cells are scanned conservatively. */
+static SCM
+allocated_mark (SCM allocated)
+{
+ scm_gc_mark_cell_conservatively (allocated);
+ return SCM_BOOL_F;
+}
/* Assert that the given object is a valid reference to a valid cell. This
* test involves to determine whether the object is a cell pointer, whether
* this pointer actually points into a heap segment and whether the cell
- * pointed to is not a free cell.
+ * pointed to is not a free cell. Further, additional garbage collections may
+ * get executed after a user defined number of cell accesses. This helps to
+ * find places in the C code where references are dropped for extremely short
+ * periods.
*/
void
scm_assert_cell_valid (SCM cell)
{
- if (scm_debug_cell_accesses_p)
+ static unsigned int already_running = 0;
+
+ if (scm_debug_cell_accesses_p && !already_running)
{
- scm_debug_cell_accesses_p = 0; /* disable to avoid recursion */
+ already_running = 1; /* set to avoid recursion */
if (!scm_cellp (cell))
{
- fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lx\n", SCM_UNPACK (cell));
+ fprintf (stderr, "scm_assert_cell_valid: Not a cell object: %lux\n",
+ (unsigned long) SCM_UNPACK (cell));
abort ();
}
else if (!scm_gc_running_p)
*/
if (SCM_FREE_CELL_P (cell))
{
- fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lx\n", SCM_UNPACK (cell));
+ fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lux\n",
+ (unsigned long) SCM_UNPACK (cell));
abort ();
}
+
+ /* If desired, perform additional garbage collections after a user
+ * defined number of cell accesses.
+ */
+ if (debug_cells_gc_interval)
+ {
+ static unsigned int counter = 0;
+
+ if (counter != 0)
+ {
+ --counter;
+ }
+ else
+ {
+ counter = debug_cells_gc_interval;
+ scm_igc ("scm_assert_cell_valid");
+ }
+ }
}
- scm_debug_cell_accesses_p = 1; /* re-enable */
+ already_running = 0; /* re-enable */
}
}
SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
(SCM flag),
- "If FLAG is #f, cell access checking is disabled.\n"
- "If FLAG is #t, cell access checking is enabled.\n"
- "This procedure only exists because the compile-time flag\n"
- "SCM_DEBUG_CELL_ACCESSES was set to 1.\n")
+ "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
+ "If @var{flag} is @code{#t}, cell access checking is enabled,\n"
+ "but no additional calls to garbage collection are issued.\n"
+ "If @var{flag} is a number, cell access checking is enabled,\n"
+ "with an additional garbage collection after the given\n"
+ "number of cell accesses.\n"
+ "This procedure only exists when the compile-time flag\n"
+ "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
#define FUNC_NAME s_scm_set_debug_cell_accesses_x
{
if (SCM_FALSEP (flag)) {
scm_debug_cell_accesses_p = 0;
} else if (SCM_EQ_P (flag, SCM_BOOL_T)) {
+ debug_cells_gc_interval = 0;
+ scm_debug_cell_accesses_p = 1;
+ } else if (SCM_INUMP (flag)) {
+ long int f = SCM_INUM (flag);
+ if (f <= 0) SCM_OUT_OF_RANGE (1, flag);
+ debug_cells_gc_interval = f;
scm_debug_cell_accesses_p = 1;
} else {
SCM_WRONG_TYPE_ARG (1, flag);
*
* If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
* will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
- * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
+ * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code
* is in scm_init_storage() and alloc_some_heap() in sys.c
*
* If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
#define SCM_DATA_CELLS2CARDS(n) (((n) + SCM_GC_CARD_N_DATA_CELLS - 1) / SCM_GC_CARD_N_DATA_CELLS)
#define SCM_CARDS_PER_CLUSTER SCM_DATA_CELLS2CARDS (2000L)
#define SCM_CLUSTER_SIZE_1 (SCM_CARDS_PER_CLUSTER * SCM_GC_CARD_N_DATA_CELLS)
-int scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1)
+size_t scm_default_init_heap_size_1 = (((SCM_DATA_CELLS2CARDS (45000L) + SCM_CARDS_PER_CLUSTER - 1)
/ SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE);
int scm_default_min_yield_1 = 40;
#define SCM_CLUSTER_SIZE_2 (SCM_CARDS_PER_CLUSTER * (SCM_GC_CARD_N_DATA_CELLS / 2))
-int scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1)
+size_t scm_default_init_heap_size_2 = (((SCM_DATA_CELLS2CARDS (2500L * 2) + SCM_CARDS_PER_CLUSTER - 1)
/ SCM_CARDS_PER_CLUSTER) * SCM_GC_CARD_SIZE);
/* The following value may seem large, but note that if we get to GC at
* all, this means that we have a numerically intensive application
*/
int scm_default_min_yield_2 = 40;
-int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */
+size_t scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */
#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE)
#ifdef _QC
/* scm_freelists
*/
-typedef struct scm_freelist_t {
+typedef struct scm_t_freelist {
/* collected cells */
SCM cells;
/* number of cells left to collect before cluster is full */
SCM clusters;
SCM *clustertail;
/* this is the number of objects in each cluster, including the spine cell */
- int cluster_size;
+ unsigned int cluster_size;
/* indicates that we should grow heap instead of GC:ing
*/
int grow_heap_p;
/* number of cells per object on this list */
int span;
/* number of collected cells during last GC */
- long collected;
+ unsigned long collected;
/* number of collected cells during penultimate GC */
- long collected_1;
+ unsigned long collected_1;
/* total number of cells in heap segments
* belonging to this list.
*/
- long heap_size;
-} scm_freelist_t;
+ unsigned long heap_size;
+} scm_t_freelist;
SCM scm_freelist = SCM_EOL;
-scm_freelist_t scm_master_freelist = {
- SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0
+scm_t_freelist scm_master_freelist = {
+ SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_1, 0, 0, 0, 1, 0, 0, 0
};
SCM scm_freelist2 = SCM_EOL;
-scm_freelist_t scm_master_freelist2 = {
- SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0
+scm_t_freelist scm_master_freelist2 = {
+ SCM_EOL, 0, 0, SCM_EOL, 0, SCM_CLUSTER_SIZE_2, 0, 0, 0, 2, 0, 0, 0
};
/* scm_mtrigger
/* GC Statistics Keeping
*/
unsigned long scm_cells_allocated = 0;
-long scm_mallocated = 0;
+unsigned long scm_mallocated = 0;
unsigned long scm_gc_cells_collected;
unsigned long scm_gc_yield;
static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */
SCM_SYMBOL (sym_cells_marked, "cells-marked");
SCM_SYMBOL (sym_cells_swept, "cells-swept");
-typedef struct scm_heap_seg_data_t
+typedef struct scm_t_heap_seg_data
{
/* lower and upper bounds of the segment */
SCM_CELLPTR bounds[2];
/* address of the head-of-freelist pointer for this segment's cells.
All segments usually point to the same one, scm_freelist. */
- scm_freelist_t *freelist;
+ scm_t_freelist *freelist;
/* number of cells per object in this segment */
int span;
-} scm_heap_seg_data_t;
+} scm_t_heap_seg_data;
-static scm_sizet init_heap_seg (SCM_CELLPTR, scm_sizet, scm_freelist_t *);
+static size_t init_heap_seg (SCM_CELLPTR, size_t, scm_t_freelist *);
typedef enum { return_on_error, abort_on_error } policy_on_error;
-static void alloc_some_heap (scm_freelist_t *, policy_on_error);
+static void alloc_some_heap (scm_t_freelist *, policy_on_error);
#define SCM_HEAP_SIZE \
#define BVEC_GROW_SIZE 256
#define BVEC_GROW_SIZE_IN_LIMBS (SCM_GC_CARD_BVEC_SIZE_IN_LIMBS * BVEC_GROW_SIZE)
-#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_c_bvec_limb_t))
+#define BVEC_GROW_SIZE_IN_BYTES (BVEC_GROW_SIZE_IN_LIMBS * sizeof (scm_t_c_bvec_limb))
/* mark space allocation */
-typedef struct scm_mark_space_t
+typedef struct scm_t_mark_space
{
- scm_c_bvec_limb_t *bvec_space;
- struct scm_mark_space_t *next;
-} scm_mark_space_t;
+ scm_t_c_bvec_limb *bvec_space;
+ struct scm_t_mark_space *next;
+} scm_t_mark_space;
-static scm_mark_space_t *current_mark_space;
-static scm_mark_space_t **mark_space_ptr;
-static int current_mark_space_offset;
-static scm_mark_space_t *mark_space_head;
+static scm_t_mark_space *current_mark_space;
+static scm_t_mark_space **mark_space_ptr;
+static ptrdiff_t current_mark_space_offset;
+static scm_t_mark_space *mark_space_head;
-static scm_c_bvec_limb_t *
+static scm_t_c_bvec_limb *
get_bvec ()
+#define FUNC_NAME "get_bvec"
{
- scm_c_bvec_limb_t *res;
+ scm_t_c_bvec_limb *res;
if (!current_mark_space)
{
- SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t)));
+ SCM_SYSCALL (current_mark_space = (scm_t_mark_space *) malloc (sizeof (scm_t_mark_space)));
if (!current_mark_space)
- scm_wta (SCM_UNDEFINED, "could not grow", "heap");
+ SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
current_mark_space->bvec_space = NULL;
current_mark_space->next = NULL;
if (!(current_mark_space->bvec_space))
{
SCM_SYSCALL (current_mark_space->bvec_space =
- (scm_c_bvec_limb_t *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1));
+ (scm_t_c_bvec_limb *) calloc (BVEC_GROW_SIZE_IN_BYTES, 1));
if (!(current_mark_space->bvec_space))
- scm_wta (SCM_UNDEFINED, "could not grow", "heap");
+ SCM_MISC_ERROR ("could not grow heap", SCM_EOL);
current_mark_space_offset = 0;
return res;
}
+#undef FUNC_NAME
+
static void
clear_mark_space ()
{
- scm_mark_space_t *ms;
+ scm_t_mark_space *ms;
for (ms = mark_space_head; ms; ms = ms->next)
memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES);
#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-/* Return the number of the heap segment containing CELL. */
-static int
-which_seg (SCM cell)
-{
- int i;
-
- for (i = 0; i < scm_n_heap_segs; i++)
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], SCM2PTR (cell))
- && SCM_PTR_GT (scm_heap_table[i].bounds[1], SCM2PTR (cell)))
- return i;
- fprintf (stderr, "which_seg: can't find segment containing cell %lx\n",
- SCM_UNPACK (cell));
- abort ();
-}
-
-
static void
-map_free_list (scm_freelist_t *master, SCM freelist)
+map_free_list (scm_t_freelist *master, SCM freelist)
{
- int last_seg = -1, count = 0;
+ long last_seg = -1, count = 0;
SCM f;
for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f))
{
- int this_seg = which_seg (f);
+ long int this_seg = heap_segment (f);
- if (this_seg != last_seg)
+ if (this_seg == -1)
+ {
+ fprintf (stderr,
+ "map_free_list: can't find segment containing cell %lux\n",
+ (unsigned long int) SCM_UNPACK (cell));
+ abort ();
+ }
+ else if (this_seg != last_seg)
{
if (last_seg != -1)
- fprintf (stderr, " %5d %d-cells in segment %d\n",
- count, master->span, last_seg);
+ fprintf (stderr, " %5ld %d-cells in segment %ld\n",
+ (long) count, master->span, (long) last_seg);
last_seg = this_seg;
count = 0;
}
count++;
}
if (last_seg != -1)
- fprintf (stderr, " %5d %d-cells in segment %d\n",
- count, master->span, last_seg);
+ fprintf (stderr, " %5ld %d-cells in segment %ld\n",
+ (long) count, master->span, (long) last_seg);
}
SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
(),
- "Print debugging information about the free-list.\n"
- "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
+ "Print debugging information about the free-list.\n"
+ "@code{map-free-list} is only included in\n"
+ "@code{--enable-guile-debug} builds of Guile.")
#define FUNC_NAME s_scm_map_free_list
{
- int i;
- fprintf (stderr, "%d segments total (%d:%d",
- scm_n_heap_segs,
+ size_t i;
+
+ fprintf (stderr, "%ld segments total (%d:%ld",
+ (long) scm_n_heap_segs,
scm_heap_table[0].span,
- scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0]);
- for (i = 1; i < scm_n_heap_segs; i++)
- fprintf (stderr, ", %d:%d",
+ (long) (scm_heap_table[0].bounds[1] - scm_heap_table[0].bounds[0]));
+
+ for (i = 1; i != scm_n_heap_segs; i++)
+ fprintf (stderr, ", %d:%ld",
scm_heap_table[i].span,
- scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0]);
+ (long) (scm_heap_table[i].bounds[1] - scm_heap_table[i].bounds[0]));
fprintf (stderr, ")\n");
map_free_list (&scm_master_freelist, scm_freelist);
map_free_list (&scm_master_freelist2, scm_freelist2);
}
#undef FUNC_NAME
-static int last_cluster;
-static int last_size;
+static long last_cluster;
+static long last_size;
-static int
-free_list_length (char *title, int i, SCM freelist)
+static long
+free_list_length (char *title, long i, SCM freelist)
{
SCM ls;
- int n = 0;
+ long n = 0;
for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls))
if (SCM_FREE_CELL_P (ls))
++n;
else
{
- fprintf (stderr, "bad cell in %s at position %d\n", title, n);
+ fprintf (stderr, "bad cell in %s at position %ld\n", title, (long) n);
abort ();
}
if (n != last_size)
if (i > 0)
{
if (last_cluster == i - 1)
- fprintf (stderr, "\t%d\n", last_size);
+ fprintf (stderr, "\t%ld\n", (long) last_size);
else
- fprintf (stderr, "-%d\t%d\n", i - 1, last_size);
+ fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size);
}
if (i >= 0)
- fprintf (stderr, "%s %d", title, i);
+ fprintf (stderr, "%s %ld", title, (long) i);
else
- fprintf (stderr, "%s\t%d\n", title, n);
+ fprintf (stderr, "%s\t%ld\n", title, (long) n);
last_cluster = i;
last_size = n;
}
}
static void
-free_list_lengths (char *title, scm_freelist_t *master, SCM freelist)
+free_list_lengths (char *title, scm_t_freelist *master, SCM freelist)
{
SCM clusters;
- int i = 0, len, n = 0;
+ long i = 0, len, n = 0;
fprintf (stderr, "%s\n\n", title);
n += free_list_length ("free list", -1, freelist);
for (clusters = master->clusters;
n += len;
}
if (last_cluster == i - 1)
- fprintf (stderr, "\t%d\n", last_size);
+ fprintf (stderr, "\t%ld\n", (long) last_size);
else
- fprintf (stderr, "-%d\t%d\n", i - 1, last_size);
- fprintf (stderr, "\ntotal %d objects\n\n", n);
+ fprintf (stderr, "-%ld\t%ld\n", (long) (i - 1), (long) last_size);
+ fprintf (stderr, "\ntotal %ld objects\n\n", (long) n);
}
SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0,
(),
- "Print debugging information about the free-list.\n"
- "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
+ "Print debugging information about the free-list.\n"
+ "@code{free-list-length} is only included in\n"
+ "@code{--enable-guile-debug} builds of Guile.")
#define FUNC_NAME s_scm_free_list_length
{
free_list_lengths ("1-cells", &scm_master_freelist, scm_freelist);
#ifdef GUILE_DEBUG_FREELIST
+/* Non-zero if freelist debugging is in effect. Set this via
+ `gc-set-debug-check-freelist!'. */
+static int scm_debug_check_freelist = 0;
+
/* Number of calls to SCM_NEWCELL since startup. */
static unsigned long scm_newcell_count;
static unsigned long scm_newcell2_count;
scm_check_freelist (SCM freelist)
{
SCM f;
- int i = 0;
+ long i = 0;
for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f), i++)
if (!SCM_FREE_CELL_P (f))
{
- fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
- scm_newcell_count, i);
+ fprintf (stderr, "Bad cell in freelist on newcell %lu: %lu'th elt\n",
+ (long) scm_newcell_count, (long) i);
abort ();
}
}
SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
(SCM flag),
- "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
- "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
- "compile-time flag was selected.\n")
+ "If @var{flag} is @code{#t}, check the freelist for consistency\n"
+ "on each cell allocation. This procedure only exists when the\n"
+ "@code{GUILE_DEBUG_FREELIST} compile-time flag was selected.")
#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
{
/* [cmm] I did a double-take when I read this code the first time.
/* The rest of this is supposed to be identical to the SCM_NEWCELL
macro. */
if (SCM_NULLP (scm_freelist))
- new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist);
+ {
+ new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist);
+ SCM_GC_SET_ALLOCATED (new);
+ }
else
{
new = scm_freelist;
scm_freelist = SCM_FREE_CELL_CDR (scm_freelist);
+ SCM_GC_SET_ALLOCATED (new);
}
return new;
/* The rest of this is supposed to be identical to the SCM_NEWCELL
macro. */
if (SCM_NULLP (scm_freelist2))
- new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
+ {
+ new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
+ SCM_GC_SET_ALLOCATED (new);
+ }
else
{
new = scm_freelist2;
scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2);
+ SCM_GC_SET_ALLOCATED (new);
}
return new;
\f
static unsigned long
-master_cells_allocated (scm_freelist_t *master)
+master_cells_allocated (scm_t_freelist *master)
{
/* the '- 1' below is to ignore the cluster spine cells. */
- int objects = master->clusters_allocated * (master->cluster_size - 1);
+ long objects = master->clusters_allocated * (master->cluster_size - 1);
if (SCM_NULLP (master->clusters))
objects -= master->left_to_collect;
return master->span * objects;
static unsigned long
freelist_length (SCM freelist)
{
- int n;
+ long n;
for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist))
++n;
return n;
SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
(),
- "Returns an association list of statistics about Guile's current use of storage. ")
+ "Return an association list of statistics about Guile's current\n"
+ "use of storage.")
#define FUNC_NAME s_scm_gc_stats
{
- int i;
- int n;
+ long i;
+ long n;
SCM heap_segs;
- long int local_scm_mtrigger;
- long int local_scm_mallocated;
- long int local_scm_heap_size;
- long int local_scm_cells_allocated;
- long int local_scm_gc_time_taken;
- long int local_scm_gc_times;
- long int local_scm_gc_mark_time_taken;
- long int local_scm_gc_sweep_time_taken;
+ unsigned long int local_scm_mtrigger;
+ unsigned long int local_scm_mallocated;
+ unsigned long int local_scm_heap_size;
+ unsigned long int local_scm_cells_allocated;
+ unsigned long int local_scm_gc_time_taken;
+ unsigned long int local_scm_gc_times;
+ unsigned long int local_scm_gc_mark_time_taken;
+ unsigned long int local_scm_gc_sweep_time_taken;
double local_scm_gc_cells_swept;
double local_scm_gc_cells_marked;
SCM answer;
local_scm_gc_cells_swept = scm_gc_cells_swept_acc;
local_scm_gc_cells_marked = scm_gc_cells_marked_acc;
- answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
- scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
- scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
- scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)),
- scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
- scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)),
- scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)),
- scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)),
- scm_cons (sym_cells_marked, scm_dbl2big (local_scm_gc_cells_marked)),
- scm_cons (sym_cells_swept, scm_dbl2big (local_scm_gc_cells_swept)),
- scm_cons (sym_heap_segments, heap_segs),
- SCM_UNDEFINED);
+ answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
+ scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
+ scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
+ scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)),
+ scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
+ scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)),
+ scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)),
+ scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)),
+ scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)),
+ scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)),
+ scm_cons (sym_heap_segments, heap_segs),
+ SCM_UNDEFINED);
SCM_ALLOW_INTS;
return answer;
}
static void
-gc_start_stats (const char *what)
+gc_start_stats (const char *what SCM_UNUSED)
{
t_before_gc = scm_c_get_internal_run_time ();
scm_gc_cells_swept = 0;
*/
static void
-adjust_min_yield (scm_freelist_t *freelist)
+adjust_min_yield (scm_t_freelist *freelist)
{
/* min yield is adjusted upwards so that next predicted total yield
* (allocated cells actually freed by GC) becomes
if (freelist->min_yield_fraction)
{
/* Pick largest of last two yields. */
- int delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100)
+ long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100)
- (long) SCM_MAX (scm_gc_yield_1, scm_gc_yield));
#ifdef DEBUGINFO
- fprintf (stderr, " after GC = %d, delta = %d\n",
- scm_cells_allocated,
- delta);
+ fprintf (stderr, " after GC = %lu, delta = %ld\n",
+ (long) scm_cells_allocated,
+ (long) delta);
#endif
if (delta > 0)
freelist->min_yield += delta;
*/
SCM
-scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist)
+scm_gc_for_newcell (scm_t_freelist *master, SCM *freelist)
{
SCM cell;
++scm_ints_disabled;
* both cases we have to try gc to get some free cells.
*/
#ifdef DEBUGINFO
- fprintf (stderr, "allocated = %d, ",
- scm_cells_allocated
+ fprintf (stderr, "allocated = %lu, ",
+ (long) (scm_cells_allocated
+ master_cells_allocated (&scm_master_freelist)
- + master_cells_allocated (&scm_master_freelist2));
+ + master_cells_allocated (&scm_master_freelist2)));
#endif
scm_igc ("cells");
adjust_min_yield (master);
*/
void
-scm_alloc_cluster (scm_freelist_t *master)
+scm_alloc_cluster (scm_t_freelist *master)
{
SCM freelist, cell;
cell = scm_gc_for_newcell (master, &freelist);
#endif
-scm_c_hook_t scm_before_gc_c_hook;
-scm_c_hook_t scm_before_mark_c_hook;
-scm_c_hook_t scm_before_sweep_c_hook;
-scm_c_hook_t scm_after_sweep_c_hook;
-scm_c_hook_t scm_after_gc_c_hook;
+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;
void
scm_igc (const char *what)
{
- int j;
+ long j;
++scm_gc_running_p;
scm_c_hook_run (&scm_before_gc_c_hook, 0);
? "*"
: (SCM_NULLP (scm_freelist2) ? "o" : "m"));
#endif
-#ifdef USE_THREADS
/* During the critical section, only the current thread may run. */
- SCM_THREAD_CRITICAL_SECTION_START;
-#endif
+ SCM_CRITICAL_SECTION_START;
/* fprintf (stderr, "gc: %s\n", what); */
gc_start_stats (what);
- if (scm_mallocated < 0)
- /* 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. */
- abort ();
-
if (scm_gc_heap_lock)
/* We've invoked the collector while a GC is already in progress.
That should never happen. */
/* flush dead entries from the continuation stack */
{
- int x;
- int bound;
+ long x;
+ long bound;
SCM * elts;
elts = SCM_VELTS (scm_continuation_stack);
bound = SCM_VECTOR_LENGTH (scm_continuation_stack);
/* This assumes that all registers are saved into the jmp_buf */
setjmp (scm_save_regs_gc_mark);
scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 +
+ ( (size_t) (sizeof (SCM_STACKITEM) - 1 +
sizeof scm_save_regs_gc_mark)
/ sizeof (SCM_STACKITEM)));
{
- scm_sizet stack_len = scm_stack_size (scm_stack_base);
+ unsigned long stack_len = scm_stack_size (scm_stack_base);
#ifdef SCM_STACK_GROWS_UP
scm_mark_locations (scm_stack_base, stack_len);
#else
while (j--)
scm_gc_mark (scm_sys_protects[j]);
+ /* mark the registered roots */
+ {
+ size_t i;
+ for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) {
+ SCM l = SCM_VELTS (scm_gc_registered_roots)[i];
+ for (; !SCM_NULLP (l); l = SCM_CDR (l)) {
+ SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
+ scm_gc_mark (*p);
+ }
+ }
+ }
+
/* FIXME: we should have a means to register C functions to be run
* in different phases of GC
*/
--scm_gc_heap_lock;
gc_end_stats ();
-#ifdef USE_THREADS
- SCM_THREAD_CRITICAL_SECTION_END;
-#endif
+ SCM_CRITICAL_SECTION_END;
scm_c_hook_run (&scm_after_gc_c_hook, 0);
--scm_gc_running_p;
}
{
register long i;
register SCM ptr;
+ scm_t_bits cell_type;
#ifndef MARK_DEPENDENCIES
# define RECURSE scm_gc_mark
goto gc_mark_loop_first_time;
#endif
+/* A simple hack for debugging. Chose the second branch to get a
+ meaningful backtrace for crashes inside the GC.
+*/
+#if 1
+#define goto_gc_mark_loop goto gc_mark_loop
+#define goto_gc_mark_nimp goto gc_mark_nimp
+#else
+#define goto_gc_mark_loop RECURSE(ptr); return
+#define goto_gc_mark_nimp RECURSE(ptr); return
+#endif
+
gc_mark_loop:
if (SCM_IMP (ptr))
return;
gc_mark_loop_first_time:
#endif
-
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
+ /* We are in debug mode. Check the ptr exhaustively. */
+ if (!scm_cellp (ptr))
+ SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
+#else
+ /* In non-debug mode, do at least some cheap testing. */
if (!SCM_CELLP (ptr))
SCM_MISC_ERROR ("rogue pointer in heap", SCM_EOL);
-
-#if (defined (GUILE_DEBUG_FREELIST))
-
- if (SCM_GC_IN_CARD_HEADERP (SCM2PTR (ptr)))
- scm_wta (ptr, "rogue pointer in heap", NULL);
-
#endif
#ifndef MARK_DEPENDENCIES
#endif
- switch (SCM_TYP7 (ptr))
+ cell_type = SCM_GC_CELL_TYPE (ptr);
+ switch (SCM_ITAG7 (cell_type))
{
case scm_tcs_cons_nimcar:
if (SCM_IMP (SCM_CDR (ptr)))
{
ptr = SCM_CAR (ptr);
- goto gc_mark_nimp;
+ goto_gc_mark_nimp;
}
RECURSE (SCM_CAR (ptr));
ptr = SCM_CDR (ptr);
- goto gc_mark_nimp;
+ goto_gc_mark_nimp;
case scm_tcs_cons_imcar:
ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
case scm_tc7_pws:
- RECURSE (SCM_CELL_OBJECT_2 (ptr));
- ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
+ RECURSE (SCM_SETTER (ptr));
+ ptr = SCM_PROCEDURE (ptr);
+ goto_gc_mark_loop;
case scm_tcs_cons_gloc:
{
- /* Dirk:FIXME:: The following code is super ugly: ptr may be a struct
- * or a gloc. If it is a gloc, the cell word #0 of ptr is a pointer
- * to a heap cell. If it is a struct, the cell word #0 of ptr is a
- * pointer to a struct vtable data region. The fact that these are
- * accessed in the same way restricts the possibilites to change the
- * data layout of structs or heap cells.
+ /* Dirk:FIXME:: The following code is super ugly: ptr may be a
+ * struct or a gloc. If it is a gloc, the cell word #0 of ptr
+ * is the address of a scm_tc16_variable smob. If it is a
+ * struct, the cell word #0 of ptr is a pointer to a struct
+ * vtable data region. (The fact that these are accessed in
+ * the same way restricts the possibilites to change the data
+ * layout of structs or heap cells.) To discriminate between
+ * the two, it is guaranteed that the scm_vtable_index_vcell
+ * element of the prospective vtable is always zero. For a
+ * gloc, this location has the CDR of the variable smob, which
+ * is guaranteed to be non-zero.
*/
- scm_bits_t word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc;
- scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */
+ scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_cons_gloc;
+ scm_t_bits * vtable_data = (scm_t_bits *) word0; /* access as struct */
if (vtable_data [scm_vtable_index_vcell] != 0)
{
/* ptr is a gloc */
{
/* ptr is a struct */
SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
- int len = SCM_SYMBOL_LENGTH (layout);
+ long len = SCM_SYMBOL_LENGTH (layout);
char * fields_desc = SCM_SYMBOL_CHARS (layout);
- scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr);
+ scm_t_bits * struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
{
}
if (len)
{
- int x;
+ long x;
for (x = 0; x < len - 2; x += 2, ++struct_data)
if (fields_desc[x] == 'p')
}
/* mark vtable */
ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
}
}
break;
case scm_tcs_closures:
- if (SCM_IMP (SCM_CDR (ptr)))
+ if (SCM_IMP (SCM_ENV (ptr)))
{
ptr = SCM_CLOSCAR (ptr);
- goto gc_mark_nimp;
+ goto_gc_mark_nimp;
}
RECURSE (SCM_CLOSCAR (ptr));
- ptr = SCM_CDR (ptr);
- goto gc_mark_nimp;
+ ptr = SCM_ENV (ptr);
+ goto_gc_mark_nimp;
case scm_tc7_vector:
i = SCM_VECTOR_LENGTH (ptr);
if (i == 0)
if (SCM_NIMP (SCM_VELTS (ptr)[i]))
RECURSE (SCM_VELTS (ptr)[i]);
ptr = SCM_VELTS (ptr)[0];
- goto gc_mark_loop;
+ goto_gc_mark_loop;
#ifdef CCLO
case scm_tc7_cclo:
{
- unsigned long int i = SCM_CCLO_LENGTH (ptr);
- unsigned long int j;
+ size_t i = SCM_CCLO_LENGTH (ptr);
+ size_t j;
for (j = 1; j != i; ++j)
{
SCM obj = SCM_CCLO_REF (ptr, j);
RECURSE (obj);
}
ptr = SCM_CCLO_REF (ptr, 0);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
}
#endif
#ifdef HAVE_ARRAYS
case scm_tc7_substring:
ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
case scm_tc7_wvect:
- SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors;
+ SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors);
scm_weak_vectors = ptr;
if (SCM_IS_WHVEC_ANY (ptr))
{
- int x;
- int len;
+ long x;
+ long len;
int weak_keys;
int weak_values;
case scm_tc7_symbol:
ptr = SCM_PROP_SLOTS (ptr);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
case scm_tcs_subrs:
break;
case scm_tc7_port:
i = SCM_PTOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
if (!(i < scm_numptob))
- goto def;
+ SCM_MISC_ERROR ("undefined port type", SCM_EOL);
+#endif
if (SCM_PTAB_ENTRY(ptr))
RECURSE (SCM_FILENAME (ptr));
if (scm_ptobs[i].mark)
{
ptr = (scm_ptobs[i].mark) (ptr);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
}
else
return;
switch (SCM_TYP16 (ptr))
{ /* should be faster than going through scm_smobs */
case scm_tc_free_cell:
- /* printf("found free_cell %X ", ptr); fflush(stdout); */
+ /* We have detected a free cell. This can happen if non-object data
+ * on the C stack points into guile's heap and is scanned during
+ * conservative marking. */
+#if (SCM_DEBUG_CELL_ACCESSES == 0)
+ /* If cell debugging is disabled, there is a second situation in
+ * which a free cell can be encountered, namely if with preemptive
+ * threading one thread has just obtained a fresh cell and was
+ * preempted before the cell initialization was completed. In this
+ * case, some entries of the cell may already contain objects.
+ * Thus, if cell debugging is disabled, free cells are scanned
+ * conservatively. */
+ scm_gc_mark_cell_conservatively (ptr);
+#else /* SCM_DEBUG_CELL_ACCESSES == 1 */
+ /* With cell debugging enabled, a freshly obtained but not fully
+ * initialized cell is guaranteed to be of type scm_tc16_allocated.
+ * Thus, no conservative scanning for free cells is necessary, but
+ * instead cells of type scm_tc16_allocated have to be scanned
+ * conservatively. This is done in the mark function of the
+ * scm_tc16_allocated smob type. */
+#endif
+ break;
case scm_tc16_big:
case scm_tc16_real:
case scm_tc16_complex:
break;
default:
i = SCM_SMOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
if (!(i < scm_numsmob))
- goto def;
+ SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
+#endif
if (scm_smobs[i].mark)
{
ptr = (scm_smobs[i].mark) (ptr);
- goto gc_mark_loop;
+ goto_gc_mark_loop;
}
else
return;
}
break;
default:
- def:
SCM_MISC_ERROR ("unknown type", SCM_EOL);
}
#undef RECURSE
#undef FNAME
-/* Mark a Region Conservatively
- */
-
-void
-scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
+/* Determine whether the given value does actually represent a cell in some
+ * heap segment. If this is the case, the number of the heap segment is
+ * returned. Otherwise, -1 is returned. Binary search is used in order to
+ * determine the heap segment that contains the cell.*/
+/* FIXME: To be used within scm_gc_mark_cell_conservatively,
+ * scm_mark_locations and scm_cellp this function should be an inline
+ * function. */
+static long int
+heap_segment (SCM obj)
{
- unsigned long m;
-
- for (m = 0; m < n; ++m)
+ if (!SCM_CELLP (obj))
+ return -1;
+ else
{
- SCM obj = * (SCM *) &x[m];
- if (SCM_CELLP (obj))
+ SCM_CELLPTR ptr = SCM2PTR (obj);
+ unsigned long int i = 0;
+ unsigned long int j = scm_n_heap_segs - 1;
+
+ if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
+ return -1;
+ else if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
+ return -1;
+ else
{
- SCM_CELLPTR ptr = SCM2PTR (obj);
- int i = 0;
- int j = scm_n_heap_segs - 1;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
+ while (i < j)
{
- while (i <= j)
+ if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[1]))
+ {
+ break;
+ }
+ else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
+ {
+ i = j;
+ break;
+ }
+ else
{
- int seg_id;
- seg_id = -1;
- if ((i == j)
- || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
- seg_id = i;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- seg_id = j;
- else
+ unsigned long int k = (i + j) / 2;
+
+ if (k == i)
+ return -1;
+ else if (SCM_PTR_LT (ptr, scm_heap_table[k].bounds[1]))
{
- int k;
- k = (i + j) / 2;
- if (k == i)
- break;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
- {
- j = k;
- ++i;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
- continue;
- else
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- continue;
- else
- break;
- }
+ j = k;
+ ++i;
+ if (SCM_PTR_LT (ptr, scm_heap_table[i].bounds[0]))
+ return -1;
+ }
+ else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
+ {
+ i = k;
+ --j;
+ if (SCM_PTR_LE (scm_heap_table[j].bounds[1], ptr))
+ return -1;
}
-
- if (SCM_GC_IN_CARD_HEADERP (ptr))
- break;
-
- if (scm_heap_table[seg_id].span == 1
- || DOUBLECELL_ALIGNED_P (obj))
- scm_gc_mark (obj);
-
- break;
}
}
+
+ if (!DOUBLECELL_ALIGNED_P (obj) && scm_heap_table[i].span == 2)
+ return -1;
+ else if (SCM_GC_IN_CARD_HEADERP (ptr))
+ return -1;
+ else
+ return i;
}
}
}
+/* Mark the entries of a cell conservatively. The given cell is known to be
+ * on the heap. Still we have to determine its heap segment in order to
+ * figure out whether it is a single or a double cell. Then, each of the cell
+ * elements itself is checked and potentially marked. */
+void
+scm_gc_mark_cell_conservatively (SCM cell)
+{
+ unsigned long int cell_segment = heap_segment (cell);
+ unsigned int span = scm_heap_table[cell_segment].span;
+ unsigned int i;
+
+ for (i = 1; i != span * 2; ++i)
+ {
+ SCM obj = SCM_CELL_OBJECT (cell, i);
+ long int obj_segment = heap_segment (obj);
+ if (obj_segment >= 0)
+ scm_gc_mark (obj);
+ }
+}
+
+
+/* Mark a region conservatively */
+void
+scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
+{
+ unsigned long m;
+
+ for (m = 0; m < n; ++m)
+ {
+ SCM obj = * (SCM *) &x[m];
+ long int segment = heap_segment (obj);
+ if (segment >= 0)
+ scm_gc_mark (obj);
+ }
+}
+
+
/* The function scm_cellp determines whether an SCM value can be regarded as a
- * pointer to a cell on the heap. Binary search is used in order to determine
- * the heap segment that contains the cell.
+ * pointer to a cell on the heap.
*/
int
scm_cellp (SCM value)
{
- if (SCM_CELLP (value)) {
- scm_cell * ptr = SCM2PTR (value);
- unsigned int i = 0;
- unsigned int j = scm_n_heap_segs - 1;
-
- while (i < j) {
- int k = (i + j) / 2;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) {
- j = k;
- } else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) {
- i = k + 1;
- }
- }
-
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)
- && (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value))
- && !SCM_GC_IN_CARD_HEADERP (ptr)
- )
- return 1;
- else
- return 0;
- } else
- return 0;
+ long int segment = heap_segment (value);
+ return (segment >= 0);
}
static void
-gc_sweep_freelist_start (scm_freelist_t *freelist)
+gc_sweep_freelist_start (scm_t_freelist *freelist)
{
freelist->cells = SCM_EOL;
freelist->left_to_collect = freelist->cluster_size;
}
static void
-gc_sweep_freelist_finish (scm_freelist_t *freelist)
+gc_sweep_freelist_finish (scm_t_freelist *freelist)
{
- int collected;
+ long collected;
*freelist->clustertail = freelist->cells;
if (!SCM_NULLP (freelist->cells))
{
SCM c = freelist->cells;
- SCM_SETCAR (c, SCM_CDR (c));
- SCM_SETCDR (c, SCM_EOL);
+ SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c));
+ SCM_SET_CELL_WORD_1 (c, SCM_EOL);
freelist->collected +=
freelist->span * (freelist->cluster_size - freelist->left_to_collect);
}
{
register SCM_CELLPTR ptr;
register SCM nfreelist;
- register scm_freelist_t *freelist;
- register long m;
+ register scm_t_freelist *freelist;
+ register unsigned long m;
register int span;
- long i;
- scm_sizet seg_size;
+ size_t i;
+ size_t seg_size;
m = 0;
for (i = 0; i < scm_n_heap_segs; i++)
{
- register unsigned int left_to_collect;
- register scm_sizet j;
+ register long left_to_collect;
+ register size_t j;
/* Unmarked cells go onto the front of the freelist this heap
segment points to. Rather than updating the real freelist
* struct or a gloc. See the corresponding comment in
* scm_gc_mark.
*/
- scm_bits_t word0 = (SCM_CELL_WORD_0 (scmptr)
+ scm_t_bits word0 = (SCM_CELL_WORD_0 (scmptr)
- scm_tc3_cons_gloc);
/* access as struct */
- scm_bits_t * vtable_data = (scm_bits_t *) word0;
+ scm_t_bits * vtable_data = (scm_t_bits *) word0;
if (vtable_data[scm_vtable_index_vcell] == 0)
{
/* Structs need to be freed in a special order.
case scm_tc7_pws:
break;
case scm_tc7_wvect:
- m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM);
- scm_must_free (SCM_VECTOR_BASE (scmptr) - 2);
- break;
case scm_tc7_vector:
{
unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
if (length > 0)
{
- m += length * sizeof (scm_bits_t);
+ m += length * sizeof (scm_t_bits);
scm_must_free (SCM_VECTOR_BASE (scmptr));
}
break;
if SCM_OPENP (scmptr)
{
int k = SCM_PTOBNUM (scmptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
if (!(k < scm_numptob))
- goto sweeperr;
+ SCM_MISC_ERROR ("undefined port type", SCM_EOL);
+#endif
/* Keep "revealed" ports alive. */
if (scm_revealed_count (scmptr) > 0)
continue;
SCM_SETSTREAM (scmptr, 0);
scm_remove_from_port_table (scmptr);
scm_gc_ports_collected++;
- SCM_SETAND_CAR (scmptr, ~SCM_OPN);
+ SCM_CLR_PORT_OPEN_FLAG (scmptr);
}
break;
case scm_tc7_smob:
break;
#endif /* def SCM_BIGDIG */
case scm_tc16_complex:
- m += sizeof (scm_complex_t);
+ m += sizeof (scm_t_complex);
scm_must_free (SCM_COMPLEX_MEM (scmptr));
break;
default:
{
int k;
k = SCM_SMOBNUM (scmptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1) || (defined (GUILE_DEBUG_FREELIST))
if (!(k < scm_numsmob))
- goto sweeperr;
- m += (scm_smobs[k].free) (scmptr);
+ SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
+#endif
+ if (scm_smobs[k].free)
+ m += (scm_smobs[k].free) (scmptr);
break;
}
}
break;
default:
- sweeperr:
SCM_MISC_ERROR ("unknown type", SCM_EOL);
}
if (!--left_to_collect)
{
- SCM_SETCAR (scmptr, nfreelist);
+ SCM_SET_CELL_WORD_0 (scmptr, nfreelist);
*freelist->clustertail = scmptr;
freelist->clustertail = SCM_CDRLOC (scmptr);
scm_cells_allocated = (SCM_HEAP_SIZE - scm_gc_cells_collected);
scm_gc_yield -= scm_cells_allocated;
+
+ if (scm_mallocated < m)
+ /* 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. */
+ abort ();
+
scm_mallocated -= m;
scm_gc_malloc_collected = m;
}
* scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
* scm_done_free
*
- * These functions provide services comperable to malloc, realloc, and
- * free. They are for allocating malloced parts of scheme objects.
- * The primary purpose of the front end is to impose calls to gc. */
-
+ * These functions provide services comparable to malloc, realloc, and
+ * free. They should be used when allocating memory that will be under
+ * control of the garbage collector, i.e., if the memory may be freed
+ * during garbage collection.
+ */
/* scm_must_malloc
* Return newly malloced storage or throw an error.
* The limit scm_mtrigger may be raised by this allocation.
*/
void *
-scm_must_malloc (scm_sizet size, const char *what)
+scm_must_malloc (size_t size, const char *what)
{
void *ptr;
unsigned long nm = scm_mallocated + size;
+ if (nm < size)
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
+
if (nm <= scm_mtrigger)
{
SCM_SYSCALL (ptr = malloc (size));
scm_igc (what);
nm = scm_mallocated + size;
+
+ if (nm < size)
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
+
SCM_SYSCALL (ptr = malloc (size));
if (NULL != ptr)
{
*/
void *
scm_must_realloc (void *where,
- scm_sizet old_size,
- scm_sizet size,
+ size_t old_size,
+ size_t size,
const char *what)
{
void *ptr;
- scm_sizet nm = scm_mallocated + size - old_size;
+ unsigned long nm;
+
+ if (size <= old_size)
+ return where;
+
+ nm = scm_mallocated + size - old_size;
+
+ if (nm < (size - old_size))
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
if (nm <= scm_mtrigger)
{
scm_igc (what);
nm = scm_mallocated + size - old_size;
+
+ if (nm < (size - old_size))
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
+
SCM_SYSCALL (ptr = realloc (where, size));
if (NULL != ptr)
{
scm_memory_error (what);
}
+char *
+scm_must_strndup (const char *str, size_t length)
+{
+ char * dst = scm_must_malloc (length + 1, "scm_must_strndup");
+ memcpy (dst, str, length);
+ dst[length] = 0;
+ return dst;
+}
+
+char *
+scm_must_strdup (const char *str)
+{
+ return scm_must_strndup (str, strlen (str));
+}
void
scm_must_free (void *obj)
void
scm_done_malloc (long size)
{
+ if (size < 0) {
+ if (scm_mallocated < size)
+ /* 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. */
+ abort ();
+ } else {
+ unsigned long nm = scm_mallocated + size;
+ if (nm < size)
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
+ }
+
scm_mallocated += size;
if (scm_mallocated > scm_mtrigger)
void
scm_done_free (long size)
{
+ if (size >= 0) {
+ if (scm_mallocated < size)
+ /* 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. */
+ abort ();
+ } else {
+ unsigned long nm = scm_mallocated + size;
+ if (nm < size)
+ /* The byte count of allocated objects has overflowed. This is
+ probably because you forgot to report the correct size of freed
+ memory in some of your smob free methods. */
+ abort ();
+ }
+
scm_mallocated -= size;
}
*/
int scm_expmem = 0;
-scm_sizet scm_max_segment_size;
+size_t scm_max_segment_size;
/* scm_heap_org
* is the lowest base address of any heap segment.
*/
SCM_CELLPTR scm_heap_org;
-scm_heap_seg_data_t * scm_heap_table = 0;
-static unsigned int heap_segment_table_size = 0;
-int scm_n_heap_segs = 0;
+scm_t_heap_seg_data * scm_heap_table = 0;
+static size_t heap_segment_table_size = 0;
+size_t scm_n_heap_segs = 0;
/* init_heap_seg
* initializes a new heap segment and returns the number of objects it contains.
SCM_GC_SET_CARD_DOUBLECELL (card); \
} while (0)
-static scm_sizet
-init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
+static size_t
+init_heap_seg (SCM_CELLPTR seg_org, size_t size, scm_t_freelist *freelist)
{
register SCM_CELLPTR ptr;
SCM_CELLPTR seg_end;
- int new_seg_index;
- int n_new_cells;
+ size_t new_seg_index;
+ ptrdiff_t n_new_cells;
int span = freelist->span;
if (seg_org == NULL)
seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size);
/* Find the right place and insert the segment record.
- *
*/
- for (new_seg_index = 0;
- ( (new_seg_index < scm_n_heap_segs)
- && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
- new_seg_index++)
- ;
+ new_seg_index = 0;
+ while (new_seg_index < scm_n_heap_segs
+ && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org))
+ new_seg_index++;
{
int i;
}
SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
- SCM_SETCDR (scmptr, PTR2SCM (nxt));
+ SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt));
ptr = nxt;
}
return size;
}
-static scm_sizet
-round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len)
+static size_t
+round_to_cluster_size (scm_t_freelist *freelist, size_t len)
{
- scm_sizet cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist);
+ size_t cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist);
return
(len + cluster_size_in_bytes - 1) / cluster_size_in_bytes * cluster_size_in_bytes
}
static void
-alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy)
+alloc_some_heap (scm_t_freelist *freelist, policy_on_error error_policy)
#define FUNC_NAME "alloc_some_heap"
{
SCM_CELLPTR ptr;
- long len;
+ size_t len;
if (scm_gc_heap_lock)
{
* segment. Do not yet increment scm_n_heap_segs -- that is done by
* init_heap_seg only if the allocation of the segment itself succeeds.
*/
- unsigned int new_table_size = scm_n_heap_segs + 1;
- size_t size = new_table_size * sizeof (scm_heap_seg_data_t);
- scm_heap_seg_data_t * new_heap_table;
+ size_t new_table_size = scm_n_heap_segs + 1;
+ size_t size = new_table_size * sizeof (scm_t_heap_seg_data);
+ scm_t_heap_seg_data *new_heap_table;
- SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *)
+ SCM_SYSCALL (new_heap_table = ((scm_t_heap_seg_data *)
realloc ((char *)scm_heap_table, size)));
if (!new_heap_table)
{
* This gives dh > (f * h - y) / (1 - f)
*/
int f = freelist->min_yield_fraction;
- long h = SCM_HEAP_SIZE;
- long min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f);
+ unsigned long h = SCM_HEAP_SIZE;
+ size_t min_cells = (f * h - 100 * (long) scm_gc_yield) / (99 - f);
len = SCM_EXPHEAP (freelist->heap_size);
#ifdef DEBUGINFO
- fprintf (stderr, "(%d < %d)", len, min_cells);
+ fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
#endif
if (len < min_cells)
len = min_cells + freelist->cluster_size;
len = scm_max_segment_size;
{
- scm_sizet smallest;
+ size_t smallest;
smallest = CLUSTER_SIZE_IN_BYTES (freelist);
while ((len >= SCM_MIN_HEAP_SEG_SIZE)
&& (len >= smallest))
{
- scm_sizet rounded_len = round_to_cluster_size (freelist, len);
+ size_t rounded_len = round_to_cluster_size (freelist, len);
SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (rounded_len));
if (ptr)
{
}
#undef FUNC_NAME
-
-SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
- (SCM name),
- "")
-#define FUNC_NAME s_scm_unhash_name
-{
- int x;
- int bound;
- SCM_VALIDATE_SYMBOL (1,name);
- SCM_DEFER_INTS;
- bound = scm_n_heap_segs;
- for (x = 0; x < bound; ++x)
- {
- SCM_CELLPTR p;
- SCM_CELLPTR pbound;
- p = scm_heap_table[x].bounds[0];
- pbound = scm_heap_table[x].bounds[1];
- while (p < pbound)
- {
- SCM cell = PTR2SCM (p);
- if (SCM_TYP3 (cell) == scm_tc3_cons_gloc)
- {
- /* Dirk:FIXME:: Again, super ugly code: cell may be a gloc or a
- * struct cell. See the corresponding comment in scm_gc_mark.
- */
- scm_bits_t word0 = SCM_CELL_WORD_0 (cell) - scm_tc3_cons_gloc;
- SCM gloc_car = SCM_PACK (word0); /* access as gloc */
- SCM vcell = SCM_CELL_OBJECT_1 (gloc_car);
- if ((SCM_EQ_P (name, SCM_BOOL_T) || SCM_EQ_P (SCM_CAR (gloc_car), name))
- && (SCM_UNPACK (vcell) != 0) && (SCM_UNPACK (vcell) != 1))
- {
- SCM_SET_CELL_OBJECT_0 (cell, name);
- }
- }
- ++p;
- }
- }
- SCM_ALLOW_INTS;
- return name;
-}
-#undef FUNC_NAME
-
-
\f
/* {GC Protection Helper Functions}
*/
* parameters. Therefore, you can be sure that the compiler will keep those
* scheme values alive (on the stack or in a register) up to the point where
* scm_remember_upto_here* is called. In other words, place the call to
- * scm_remember_upt_here* _behind_ the last code in your function, that
+ * scm_remember_upto_here* _behind_ the last code in your function, that
* depends on the scheme object to exist.
*
* Example: We want to make sure, that the string object str does not get
*/
void
-scm_remember_upto_here_1 (SCM obj)
+scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
{
/* Empty. Protects a single object from garbage collection. */
}
void
-scm_remember_upto_here_2 (SCM obj1, SCM obj2)
+scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
{
/* Empty. Protects two objects from garbage collection. */
}
void
-scm_remember_upto_here (SCM obj, ...)
+scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
{
/* Empty. Protects any number of objects from garbage collection. */
}
void
scm_remember (SCM *ptr)
{
- /* empty */
+ scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
+ "Use the `scm_remember_upto_here*' family of functions instead.");
+}
+
+SCM
+scm_protect_object (SCM obj)
+{
+ scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
+ "Use `scm_gc_protect_object' instead.");
+ return scm_gc_protect_object (obj);
+}
+
+SCM
+scm_unprotect_object (SCM obj)
+{
+ scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
+ "Use `scm_gc_unprotect_object' instead.");
+ return scm_gc_unprotect_object (obj);
}
#endif /* SCM_DEBUG_DEPRECATED == 0 */
/* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
other references are dropped, until the object is unprotected by calling
- scm_unprotect_object (OBJ). Calls to scm_protect/unprotect_object nest,
+ scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
i. e. it is possible to protect the same object several times, but it is
necessary to unprotect the object the same number of times to actually get
the object unprotected. It is an error to unprotect an object more often
*/
/* Implementation note: For every object X, there is a counter which
- scm_protect_object(X) increments and scm_unprotect_object(X) decrements.
+ scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
*/
SCM
-scm_protect_object (SCM obj)
+scm_gc_protect_object (SCM obj)
{
SCM handle;
SCM_REDEFER_INTS;
handle = scm_hashq_create_handle_x (scm_protects, obj, SCM_MAKINUM (0));
- SCM_SETCDR (handle, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle)) + 1));
+ SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1)));
SCM_REALLOW_INTS;
See scm_protect_object for more information. */
SCM
-scm_unprotect_object (SCM obj)
+scm_gc_unprotect_object (SCM obj)
{
SCM handle;
handle = scm_hashq_get_handle (scm_protects, obj);
- if (SCM_IMP (handle))
+ if (SCM_FALSEP (handle))
{
fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
abort ();
}
else
{
- unsigned long int count = SCM_INUM (SCM_CDR (handle)) - 1;
- if (count == 0)
+ SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1));
+ if (SCM_EQ_P (count, SCM_MAKINUM (0)))
scm_hashq_remove_x (scm_protects, obj);
else
- SCM_SETCDR (handle, SCM_MAKINUM (count));
+ SCM_SETCDR (handle, count);
}
SCM_REALLOW_INTS;
return obj;
}
+void
+scm_gc_register_root (SCM *p)
+{
+ SCM handle;
+ SCM key = scm_long2num ((long) p);
+
+ /* This critical section barrier will be replaced by a mutex. */
+ SCM_REDEFER_INTS;
+
+ handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, SCM_MAKINUM (0));
+ SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1)));
+
+ SCM_REALLOW_INTS;
+}
+
+void
+scm_gc_unregister_root (SCM *p)
+{
+ SCM handle;
+ SCM key = scm_long2num ((long) p);
+
+ /* This critical section barrier will be replaced by a mutex. */
+ SCM_REDEFER_INTS;
+
+ handle = scm_hashv_get_handle (scm_gc_registered_roots, key);
+
+ if (SCM_FALSEP (handle))
+ {
+ fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n");
+ abort ();
+ }
+ else
+ {
+ SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1));
+ if (SCM_EQ_P (count, SCM_MAKINUM (0)))
+ scm_hashv_remove_x (scm_gc_registered_roots, key);
+ else
+ SCM_SETCDR (handle, count);
+ }
+
+ SCM_REALLOW_INTS;
+}
+
+void
+scm_gc_register_roots (SCM *b, unsigned long n)
+{
+ SCM *p = b;
+ for (; p < b + n; ++p)
+ scm_gc_register_root (p);
+}
+
+void
+scm_gc_unregister_roots (SCM *b, unsigned long n)
+{
+ SCM *p = b;
+ for (; p < b + n; ++p)
+ scm_gc_unregister_root (p);
+}
+
int terminating;
/* called on process termination. */
\f
static int
-make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist)
+make_initial_segment (size_t init_heap_size, scm_t_freelist *freelist)
{
- scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size);
+ size_t rounded_size = round_to_cluster_size (freelist, init_heap_size);
if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
rounded_size,
\f
static void
-init_freelist (scm_freelist_t *freelist,
+init_freelist (scm_t_freelist *freelist,
int span,
- int cluster_size,
+ long cluster_size,
int min_yield)
{
freelist->clusters = SCM_EOL;
int
scm_init_storage ()
{
- scm_sizet gc_trigger_1;
- scm_sizet gc_trigger_2;
- scm_sizet init_heap_size_1;
- scm_sizet init_heap_size_2;
- scm_sizet j;
+ unsigned long gc_trigger_1;
+ unsigned long gc_trigger_2;
+ size_t init_heap_size_1;
+ size_t init_heap_size_2;
+ size_t j;
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
+ scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
+#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
j = SCM_NUM_PROTECTS;
while (j)
j = SCM_HEAP_SEG_SIZE;
scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
- scm_heap_table = ((scm_heap_seg_data_t *)
- scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims"));
+ scm_heap_table = ((scm_t_heap_seg_data *)
+ scm_must_malloc (sizeof (scm_t_heap_seg_data) * 2, "hplims"));
heap_segment_table_size = 2;
mark_space_ptr = &mark_space_head;
scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
/* Initialise the list of ports. */
- scm_port_table = (scm_port **)
- malloc (sizeof (scm_port *) * scm_port_table_room);
- if (!scm_port_table)
+ scm_t_portable = (scm_t_port **)
+ malloc (sizeof (scm_t_port *) * scm_t_portable_room);
+ if (!scm_t_portable)
return 1;
#ifdef HAVE_ATEXIT
#endif
#endif
- scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
- SCM_SETCDR (scm_undefineds, scm_undefineds);
-
- scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
- scm_nullstr = scm_makstr (0L, 0);
- scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
-
-#define DEFAULT_SYMHASH_SIZE 277
- scm_symhash = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE);
- scm_symhash_vars = scm_c_make_hash_table (DEFAULT_SYMHASH_SIZE);
-
scm_stand_in_procs = SCM_EOL;
scm_permobjs = SCM_EOL;
scm_protects = scm_c_make_hash_table (31);
+ scm_gc_registered_roots = scm_c_make_hash_table (31);
return 0;
}
SCM scm_after_gc_hook;
-#if (SCM_DEBUG_DEPRECATED == 0)
-static SCM scm_gc_vcell; /* the vcell for gc-thunk. */
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
static SCM gc_async;
-
/* The function gc_async_thunk causes the execution of the after-gc-hook. It
* is run after the gc, as soon as the asynchronous events are handled by the
* evaluator.
gc_async_thunk (void)
{
scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
-
-#if (SCM_DEBUG_DEPRECATED == 0)
-
- /* The following code will be removed in Guile 1.5. */
- if (SCM_NFALSEP (scm_gc_vcell))
- {
- SCM proc = SCM_CDR (scm_gc_vcell);
-
- if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc))
- scm_apply (proc, SCM_EOL, SCM_EOL);
- }
-
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
-
return SCM_UNSPECIFIED;
}
* gc_async_thunk).
*/
static void *
-mark_gc_async (void * hook_data, void *func_data, void *data)
+mark_gc_async (void * hook_data SCM_UNUSED,
+ void *func_data SCM_UNUSED,
+ void *data SCM_UNUSED)
{
+ /* If cell access debugging is enabled, the user may choose to perform
+ * additional garbage collections after an arbitrary number of cell
+ * accesses. We don't want the scheme level after-gc-hook to be performed
+ * for each of these garbage collections for the following reason: The
+ * execution of the after-gc-hook causes cell accesses itself. Thus, if the
+ * after-gc-hook was performed with every gc, and if the gc was performed
+ * after a very small number of cell accesses, then the number of cell
+ * accesses during the execution of the after-gc-hook will suffice to cause
+ * the execution of the next gc. Then, guile would keep executing the
+ * after-gc-hook over and over again, and would never come to do other
+ * things.
+ *
+ * To overcome this problem, if cell access debugging with additional
+ * garbage collections is enabled, the after-gc-hook is never run by the
+ * garbage collecter. When running guile with cell access debugging and the
+ * execution of the after-gc-hook is desired, then it is necessary to run
+ * the hook explicitly from the user code. This has the effect, that from
+ * the scheme level point of view it seems that garbage collection is
+ * performed with a much lower frequency than it actually is. Obviously,
+ * this will not work for code that depends on a fixed one to one
+ * relationship between the execution counts of the C level garbage
+ * collection hooks and the execution count of the scheme level
+ * after-gc-hook.
+ */
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (debug_cells_gc_interval == 0)
+ scm_system_async_mark (gc_async);
+#else
scm_system_async_mark (gc_async);
+#endif
+
return NULL;
}
{
SCM after_gc_thunk;
- scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0);
+ scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
+ scm_c_define ("after-gc-hook", scm_after_gc_hook);
-#if (SCM_DEBUG_DEPRECATED == 0)
- scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F);
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
- after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0);
+ after_gc_thunk = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0,
+ gc_async_thunk);
gc_async = scm_system_async (after_gc_thunk); /* protected via scm_asyncs */
scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
HCoop / bpt / guile.git / blobdiff