X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/206d3de31e939c895bdbd31ade1909e03b2e1293..e200c20fa0f6d1514256c6ccdca5fe452dc030e5:/libguile/gc.c diff --git a/libguile/gc.c b/libguile/gc.c index 353bcee00..cef92aca9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* 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 @@ -44,9 +44,18 @@ /* #define DEBUGINFO */ +/* SECTION: This code is compiled once. + */ + +#ifndef MARK_DEPENDENCIES + #include +#include +#include + #include "libguile/_scm.h" +#include "libguile/eval.h" #include "libguile/stime.h" #include "libguile/stackchk.h" #include "libguile/struct.h" @@ -59,6 +68,7 @@ #include "libguile/vectors.h" #include "libguile/weaks.h" #include "libguile/hashtab.h" +#include "libguile/tags.h" #include "libguile/validate.h" #include "libguile/gc.h" @@ -84,6 +94,84 @@ #endif + +unsigned int scm_gc_running_p = 0; + + + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + +scm_bits_t scm_tc16_allocated; + +/* Set this to != 0 if every cell that is accessed shall be checked: + */ +unsigned int scm_debug_cell_accesses_p = 1; + + +/* 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. + */ +void +scm_assert_cell_valid (SCM cell) +{ + static unsigned int already_running = 0; + + if (scm_debug_cell_accesses_p && !already_running) + { + 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)); + abort (); + } + else if (!scm_gc_running_p) + { + /* Dirk::FIXME:: During garbage collection there occur references to + free cells. This is allright during conservative marking, but + should not happen otherwise (I think). The case of free cells + accessed during conservative marking is handled in function + scm_mark_locations. However, there still occur accesses to free + cells during gc. I don't understand why this happens. If it is + a bug and gets fixed, the following test should also work while + gc is running. + */ + if (SCM_FREE_CELL_P (cell)) + { + fprintf (stderr, "scm_assert_cell_valid: Accessing free cell: %lx\n", SCM_UNPACK (cell)); + abort (); + } + } + already_running = 0; /* re-enable */ + } +} + + +SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, + (SCM flag), + "If @var{flag} is @code{#f}, cell access checking is disabled.\n" + "If @var{flag} is @code{#t}, cell access checking is enabled.\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)) { + scm_debug_cell_accesses_p = 1; + } else { + SCM_WRONG_TYPE_ARG (1, flag); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + + + /* {heap tuning parameters} * * These are parameters for controlling memory allocation. The heap @@ -124,20 +212,25 @@ * large heaps, especially if code behaviour is varying its * maximum consumption between different freelists. */ -#define SCM_INIT_HEAP_SIZE_1 (45000L * sizeof (scm_cell)) -#define SCM_CLUSTER_SIZE_1 2000L -#define SCM_MIN_YIELD_1 40 -#define SCM_INIT_HEAP_SIZE_2 (2500L * 2 * sizeof (scm_cell)) -#define SCM_CLUSTER_SIZE_2 1000L +#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) + / 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) + / 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 */ -#define SCM_MIN_YIELD_2 40 +int scm_default_min_yield_2 = 40; -#define SCM_MAX_SEGMENT_SIZE 2097000L /* a little less (adm) than 2 Mb */ +int scm_default_max_segment_size = 2097000L;/* a little less (adm) than 2 Mb */ -#define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell)) +#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_CARD_SIZE) #ifdef _QC # define SCM_HEAP_SEG_SIZE 32768L #else @@ -152,8 +245,8 @@ #define SCM_INIT_MALLOC_LIMIT 100000 #define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner - bounds for allocated storage */ +/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_cell * span) + aligned inner bounds for allocated storage */ #ifdef PROT386 /*in 386 protected mode we must only adjust the offset */ @@ -168,12 +261,12 @@ # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ -#define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell)) -#define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1) -#define SCM_HEAP_SIZE \ - (scm_master_freelist.heap_size + scm_master_freelist2.heap_size) -#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) +#define DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x)) == 0) + +#define ALIGNMENT_SLACK(freelist) (SCM_GC_CARD_SIZE - 1) +#define CLUSTER_SIZE_IN_BYTES(freelist) \ + (((freelist)->cluster_size / (SCM_GC_CARD_N_DATA_CELLS / (freelist)->span)) * SCM_GC_CARD_SIZE) /* scm_freelists @@ -228,7 +321,6 @@ scm_freelist_t scm_master_freelist2 = { */ unsigned long scm_mtrigger; - /* scm_gc_heap_lock * If set, don't expand the heap. Set only during gc, during which no allocation * is supposed to take place anyway. @@ -239,19 +331,17 @@ int scm_gc_heap_lock = 0; * Don't pause for collection if this is set -- just * expand the heap. */ - int scm_block_gc = 1; -/* If fewer than MIN_GC_YIELD cells are recovered during a garbage - * collection (GC) more space is allocated for the heap. - */ -#define MIN_GC_YIELD(freelist) (freelist->heap_size / 4) - /* During collection, this accumulates objects holding * weak references. */ SCM scm_weak_vectors; +/* During collection, this accumulates structures which are to be freed. + */ +SCM scm_structs_to_free; + /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; @@ -261,8 +351,15 @@ unsigned long scm_gc_yield; static unsigned long scm_gc_yield_1 = 0; /* previous GC yield */ unsigned long scm_gc_malloc_collected; unsigned long scm_gc_ports_collected; -unsigned long scm_gc_rt; unsigned long scm_gc_time_taken = 0; +static unsigned long t_before_gc; +static unsigned long t_before_sweep; +unsigned long scm_gc_mark_time_taken = 0; +unsigned long scm_gc_sweep_time_taken = 0; +unsigned long scm_gc_times = 0; +unsigned long scm_gc_cells_swept = 0; +double scm_gc_cells_marked_acc = 0.; +double scm_gc_cells_swept_acc = 0.; SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); SCM_SYMBOL (sym_heap_size, "cell-heap-size"); @@ -270,6 +367,11 @@ SCM_SYMBOL (sym_mallocated, "bytes-malloced"); SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); +SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken"); +SCM_SYMBOL (sym_gc_sweep_time_taken, "gc-sweep-time-taken"); +SCM_SYMBOL (sym_times, "gc-times"); +SCM_SYMBOL (sym_cells_marked, "cells-marked"); +SCM_SYMBOL (sym_cells_swept, "cells-swept"); typedef struct scm_heap_seg_data_t { @@ -282,18 +384,93 @@ typedef struct scm_heap_seg_data_t /* number of cells per object in this segment */ int span; - - /* If SEG_DATA->valid is non-zero, the conservative marking - functions will apply SEG_DATA->valid to the purported pointer and - SEG_DATA, and mark the object iff the function returns non-zero. - At the moment, I don't think anyone uses this. */ - int (*valid) (); } scm_heap_seg_data_t; static scm_sizet init_heap_seg (SCM_CELLPTR, scm_sizet, scm_freelist_t *); -static void alloc_some_heap (scm_freelist_t *); + +typedef enum { return_on_error, abort_on_error } policy_on_error; +static void alloc_some_heap (scm_freelist_t *, policy_on_error); + + +#define SCM_HEAP_SIZE \ + (scm_master_freelist.heap_size + scm_master_freelist2.heap_size) +#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) + +#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)) + +/* mark space allocation */ + +typedef struct scm_mark_space_t +{ + scm_c_bvec_limb_t *bvec_space; + struct scm_mark_space_t *next; +} scm_mark_space_t; + +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_c_bvec_limb_t * +get_bvec () +#define FUNC_NAME "get_bvec" +{ + scm_c_bvec_limb_t *res; + + if (!current_mark_space) + { + SCM_SYSCALL (current_mark_space = (scm_mark_space_t *) malloc (sizeof (scm_mark_space_t))); + if (!current_mark_space) + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); + + current_mark_space->bvec_space = NULL; + current_mark_space->next = NULL; + + *mark_space_ptr = current_mark_space; + mark_space_ptr = &(current_mark_space->next); + + return get_bvec (); + } + + 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)); + if (!(current_mark_space->bvec_space)) + SCM_MISC_ERROR ("could not grow heap", SCM_EOL); + + current_mark_space_offset = 0; + + return get_bvec (); + } + + if (current_mark_space_offset == BVEC_GROW_SIZE_IN_LIMBS) + { + current_mark_space = NULL; + + return get_bvec (); + } + + res = current_mark_space->bvec_space + current_mark_space_offset; + current_mark_space_offset += SCM_GC_CARD_BVEC_SIZE_IN_LIMBS; + + return res; +} +#undef FUNC_NAME + + +static void +clear_mark_space () +{ + scm_mark_space_t *ms; + + for (ms = mark_space_head; ms; ms = ms->next) + memset (ms->bvec_space, 0, BVEC_GROW_SIZE_IN_BYTES); +} @@ -323,7 +500,7 @@ map_free_list (scm_freelist_t *master, SCM freelist) int last_seg = -1, count = 0; SCM f; - for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f)) + for (f = freelist; !SCM_NULLP (f); f = SCM_FREE_CELL_CDR (f)) { int this_seg = which_seg (f); @@ -344,8 +521,9 @@ map_free_list (scm_freelist_t *master, SCM freelist) 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; @@ -374,8 +552,8 @@ free_list_length (char *title, int i, SCM freelist) { SCM ls; int n = 0; - for (ls = freelist; SCM_NNULLP (ls); ls = SCM_CDR (ls)) - if (SCM_CELL_TYPE (ls) == scm_tc_free_cell) + for (ls = freelist; !SCM_NULLP (ls); ls = SCM_FREE_CELL_CDR (ls)) + if (SCM_FREE_CELL_P (ls)) ++n; else { @@ -424,8 +602,9 @@ free_list_lengths (char *title, scm_freelist_t *master, SCM freelist) 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); @@ -438,6 +617,10 @@ SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0, #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; @@ -450,25 +633,24 @@ scm_check_freelist (SCM freelist) SCM f; int i = 0; - for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f), i++) - if (SCM_CAR (f) != (SCM) scm_tc_free_cell) + 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); - fflush (stderr); abort (); } } -static int scm_debug_check_freelist = 0; - 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. + well, FWIW. */ SCM_VALIDATE_BOOL_COPY (1, flag, scm_debug_check_freelist); return SCM_UNSPECIFIED; } @@ -489,13 +671,12 @@ scm_debug_newcell (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ - if (SCM_IMP (scm_freelist)) + if (SCM_NULLP (scm_freelist)) new = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist); else { new = scm_freelist; - scm_freelist = SCM_CDR (scm_freelist); - SCM_SETCAR (new, scm_tc16_allocated); + scm_freelist = SCM_FREE_CELL_CDR (scm_freelist); } return new; @@ -515,13 +696,12 @@ scm_debug_newcell2 (void) /* The rest of this is supposed to be identical to the SCM_NEWCELL macro. */ - if (SCM_IMP (scm_freelist2)) + if (SCM_NULLP (scm_freelist2)) new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2); else { new = scm_freelist2; - scm_freelist2 = SCM_CDR (scm_freelist2); - SCM_SETCAR (new, scm_tc16_allocated); + scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2); } return new; @@ -534,6 +714,7 @@ scm_debug_newcell2 (void) static unsigned long master_cells_allocated (scm_freelist_t *master) { + /* the '- 1' below is to ignore the cluster spine cells. */ int objects = master->clusters_allocated * (master->cluster_size - 1); if (SCM_NULLP (master->clusters)) objects -= master->left_to_collect; @@ -544,7 +725,7 @@ static unsigned long freelist_length (SCM freelist) { int n; - for (n = 0; SCM_NNULLP (freelist); freelist = SCM_CDR (freelist)) + for (n = 0; !SCM_NULLP (freelist); freelist = SCM_FREE_CELL_CDR (freelist)) ++n; return n; } @@ -564,7 +745,8 @@ compute_cells_allocated () 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; @@ -575,10 +757,17 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, 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; + double local_scm_gc_cells_swept; + double local_scm_gc_cells_marked; SCM answer; SCM_DEFER_INTS; - scm_block_gc = 1; + + ++scm_block_gc; + retry: heap_segs = SCM_EOL; n = scm_n_heap_segs; @@ -588,7 +777,8 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, heap_segs); if (scm_n_heap_segs != n) goto retry; - scm_block_gc = 0; + + --scm_block_gc; /* Below, we cons to produce the resulting list. We want a snapshot of * the heap situation before consing. @@ -598,12 +788,22 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_heap_size = SCM_HEAP_SIZE; local_scm_cells_allocated = compute_cells_allocated (); local_scm_gc_time_taken = scm_gc_time_taken; + local_scm_gc_mark_time_taken = scm_gc_mark_time_taken; + local_scm_gc_sweep_time_taken = scm_gc_sweep_time_taken; + local_scm_gc_times = scm_gc_times; + 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); SCM_ALLOW_INTS; @@ -612,10 +812,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, #undef FUNC_NAME -void -scm_gc_start (const char *what) +static void +gc_start_stats (const char *what) { - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); + t_before_gc = scm_c_get_internal_run_time (); + scm_gc_cells_swept = 0; scm_gc_cells_collected = 0; scm_gc_yield_1 = scm_gc_yield; scm_gc_yield = (scm_cells_allocated @@ -625,12 +826,17 @@ scm_gc_start (const char *what) scm_gc_ports_collected = 0; } -void -scm_gc_end () + +static void +gc_end_stats () { - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; - scm_gc_time_taken += scm_gc_rt; - scm_system_async_mark (scm_gc_async); + unsigned long t = scm_c_get_internal_run_time (); + scm_gc_time_taken += (t - t_before_gc); + scm_gc_sweep_time_taken += (t - t_before_sweep); + ++scm_gc_times; + + scm_gc_cells_marked_acc += scm_gc_cells_swept - scm_gc_cells_collected; + scm_gc_cells_swept_acc += scm_gc_cells_swept; } @@ -695,6 +901,7 @@ adjust_min_yield (scm_freelist_t *freelist) } } + /* When we get POSIX threads support, the master will be global and * common while the freelist will be individual for each thread. */ @@ -708,13 +915,21 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) { if (SCM_NULLP (master->clusters)) { - if (master->grow_heap_p) + if (master->grow_heap_p || scm_block_gc) { + /* In order to reduce gc frequency, try to allocate a new heap + * segment first, even if gc might find some free cells. If we + * can't obtain a new heap segment, we will try gc later. + */ master->grow_heap_p = 0; - alloc_some_heap (master); + alloc_some_heap (master, return_on_error); } - else + if (SCM_NULLP (master->clusters)) { + /* The heap was not grown, either because it wasn't scheduled to + * grow, or because there was not enough memory available. In + * both cases we have to try gc to get some free cells. + */ #ifdef DEBUGINFO fprintf (stderr, "allocated = %d, ", scm_cells_allocated @@ -723,6 +938,14 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) #endif scm_igc ("cells"); adjust_min_yield (master); + if (SCM_NULLP (master->clusters)) + { + /* gc could not free any cells. Now, we _must_ allocate a + * new heap segment, because there is no other possibility + * to provide a new cell for the caller. + */ + alloc_some_heap (master, abort_on_error); + } } } cell = SCM_CAR (master->clusters); @@ -730,12 +953,17 @@ scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist) ++master->clusters_allocated; } while (SCM_NULLP (cell)); + +#ifdef GUILE_DEBUG_FREELIST + scm_check_freelist (cell); +#endif + --scm_ints_disabled; - *freelist = SCM_CDR (cell); - SCM_SET_CELL_TYPE (cell, scm_tc16_allocated); + *freelist = SCM_FREE_CELL_CDR (cell); return cell; } + #if 0 /* This is a support routine which can be used to reserve a cluster * for some special use, such as debugging. It won't be useful until @@ -752,7 +980,6 @@ scm_alloc_cluster (scm_freelist_t *master) } #endif -SCM scm_after_gc_hook; scm_c_hook_t scm_before_gc_c_hook; scm_c_hook_t scm_before_mark_c_hook; @@ -760,11 +987,13 @@ 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; + void scm_igc (const char *what) { int j; + ++scm_gc_running_p; scm_c_hook_run (&scm_before_gc_c_hook, 0); #ifdef DEBUGINFO fprintf (stderr, @@ -772,21 +1001,19 @@ scm_igc (const char *what) ? "*" : (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); */ - scm_gc_start (what); - if (!scm_stack_base || scm_block_gc) { - scm_gc_end (); + --scm_gc_running_p; return; } + 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 @@ -802,35 +1029,13 @@ scm_igc (const char *what) ++scm_gc_heap_lock; - /* unprotect any struct types with no instances */ -#if 0 - { - SCM type_list; - SCM * pos; - - pos = &scm_type_obj_list; - type_list = scm_type_obj_list; - while (type_list != SCM_EOL) - if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt]) - { - pos = SCM_CDRLOC (type_list); - type_list = SCM_CDR (type_list); - } - else - { - *pos = SCM_CDR (type_list); - type_list = SCM_CDR (type_list); - } - } -#endif - /* flush dead entries from the continuation stack */ { int x; int bound; SCM * elts; elts = SCM_VELTS (scm_continuation_stack); - bound = SCM_LENGTH (scm_continuation_stack); + bound = SCM_VECTOR_LENGTH (scm_continuation_stack); x = SCM_INUM (scm_continuation_stack_ptr); while (x < bound) { @@ -841,16 +1046,11 @@ scm_igc (const char *what) scm_c_hook_run (&scm_before_mark_c_hook, 0); + clear_mark_space (); + #ifndef USE_THREADS - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_vector_set_length_x. - */ + /* Mark objects on the C stack. */ SCM_FLUSH_REGISTER_WINDOWS; /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); @@ -875,10 +1075,6 @@ scm_igc (const char *what) #endif /* USE_THREADS */ - /* FIXME: insert a phase to un-protect string-data preserved - * in scm_vector_set_length_x. - */ - j = SCM_NUM_PROTECTS; while (j--) scm_gc_mark (scm_sys_protects[j]); @@ -892,6 +1088,9 @@ scm_igc (const char *what) scm_gc_mark (scm_root->handle); #endif + t_before_sweep = scm_c_get_internal_run_time (); + scm_gc_mark_time_taken += (t_before_sweep - t_before_gc); + scm_c_hook_run (&scm_before_sweep_c_hook, 0); scm_gc_sweep (); @@ -899,171 +1098,186 @@ scm_igc (const char *what) scm_c_hook_run (&scm_after_sweep_c_hook, 0); --scm_gc_heap_lock; - scm_gc_end (); + 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; } + /* {Mark/Sweep} */ +#define MARK scm_gc_mark +#define FNAME "scm_gc_mark" +#endif /*!MARK_DEPENDENCIES*/ /* Mark an object precisely. */ void -scm_gc_mark (SCM p) +MARK (SCM p) +#define FUNC_NAME FNAME { register long i; register SCM ptr; + scm_bits_t cell_type; +#ifndef MARK_DEPENDENCIES +# define RECURSE scm_gc_mark +#else + /* go through the usual marking, but not for self-cycles. */ +# define RECURSE(x) do { if ((x) != p) scm_gc_mark (x); } while (0) +#endif ptr = p; +#ifdef MARK_DEPENDENCIES + goto gc_mark_loop_first_time; +#endif + gc_mark_loop: if (SCM_IMP (ptr)) return; gc_mark_nimp: - if (SCM_NCELLP (ptr)) - scm_wta (ptr, "rogue pointer in heap", NULL); + +#ifdef MARK_DEPENDENCIES + if (SCM_EQ_P (ptr, p)) + return; + + scm_gc_mark (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); +#endif + +#ifndef MARK_DEPENDENCIES + + if (SCM_GCMARKP (ptr)) + return; + + SCM_SETGCMARK (ptr); - switch (SCM_TYP7 (ptr)) +#endif + + cell_type = SCM_GC_CELL_TYPE (ptr); + switch (SCM_ITAG7 (cell_type)) { case scm_tcs_cons_nimcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */ + if (SCM_IMP (SCM_CDR (ptr))) { ptr = SCM_CAR (ptr); goto gc_mark_nimp; } - scm_gc_mark (SCM_CAR (ptr)); - ptr = SCM_GCCDR (ptr); + RECURSE (SCM_CAR (ptr)); + ptr = SCM_CDR (ptr); goto gc_mark_nimp; case scm_tcs_cons_imcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - ptr = SCM_GCCDR (ptr); + ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_pws: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - scm_gc_mark (SCM_CELL_OBJECT_2 (ptr)); - ptr = SCM_GCCDR (ptr); + RECURSE (SCM_SETTER (ptr)); + ptr = SCM_PROCEDURE (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); { /* 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. + * data layout of structs or heap cells. */ 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 */ - switch (vtable_data [scm_vtable_index_vcell]) + if (vtable_data [scm_vtable_index_vcell] != 0) { - default: - { - /* ptr is a gloc */ - SCM gloc_car = SCM_PACK (word0); - scm_gc_mark (gloc_car); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - } - case 1: /* ! */ - case 0: /* ! */ - { - /* ptr is a struct */ - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - int len = SCM_LENGTH (layout); - char * fields_desc = SCM_CHARS (layout); - /* We're using SCM_GCCDR here like STRUCT_DATA, except - that it removes the mark */ - scm_bits_t * struct_data = (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (ptr)); - - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - int x; - - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - scm_gc_mark (SCM_PACK (*struct_data)); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data; x; --x) - scm_gc_mark (SCM_PACK (*++struct_data)); - else - scm_gc_mark (SCM_PACK (*struct_data)); - } - } - if (vtable_data [scm_vtable_index_vcell] == 0) - { - vtable_data [scm_vtable_index_vcell] = 1; - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; - } - } + /* ptr is a gloc */ + SCM gloc_car = SCM_PACK (word0); + RECURSE (gloc_car); + ptr = SCM_CDR (ptr); + goto gc_mark_loop; + } + else + { + /* ptr is a struct */ + SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); + int len = SCM_SYMBOL_LENGTH (layout); + char * fields_desc = SCM_SYMBOL_CHARS (layout); + scm_bits_t * struct_data = (scm_bits_t *) SCM_STRUCT_DATA (ptr); + + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + RECURSE (SCM_PACK (struct_data[scm_struct_i_procedure])); + RECURSE (SCM_PACK (struct_data[scm_struct_i_setter])); + } + if (len) + { + int x; + + for (x = 0; x < len - 2; x += 2, ++struct_data) + if (fields_desc[x] == 'p') + RECURSE (SCM_PACK (*struct_data)); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *struct_data++; x; --x, ++struct_data) + RECURSE (SCM_PACK (*struct_data)); + else + RECURSE (SCM_PACK (*struct_data)); + } + } + /* mark vtable */ + ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); + goto gc_mark_loop; } } break; case scm_tcs_closures: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) + if (SCM_IMP (SCM_ENV (ptr))) { ptr = SCM_CLOSCAR (ptr); goto gc_mark_nimp; } - scm_gc_mark (SCM_CLOSCAR (ptr)); - ptr = SCM_GCCDR (ptr); + RECURSE (SCM_CLOSCAR (ptr)); + ptr = SCM_ENV (ptr); goto gc_mark_nimp; case scm_tc7_vector: - case scm_tc7_lvector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); - i = SCM_LENGTH (ptr); + i = SCM_VECTOR_LENGTH (ptr); if (i == 0) break; while (--i > 0) if (SCM_NIMP (SCM_VELTS (ptr)[i])) - scm_gc_mark (SCM_VELTS (ptr)[i]); + RECURSE (SCM_VELTS (ptr)[i]); ptr = SCM_VELTS (ptr)[0]; goto gc_mark_loop; - case scm_tc7_contin: - if SCM_GC8MARKP - (ptr) break; - SCM_SETGC8MARK (ptr); - if (SCM_VELTS (ptr)) - scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr), - (scm_sizet) - (SCM_LENGTH (ptr) + - (sizeof (SCM_STACKITEM) + -1 + - sizeof (scm_contregs)) / - sizeof (SCM_STACKITEM))); - break; +#ifdef CCLO + case scm_tc7_cclo: + { + unsigned long int i = SCM_CCLO_LENGTH (ptr); + unsigned long int j; + for (j = 1; j != i; ++j) + { + SCM obj = SCM_CCLO_REF (ptr, j); + if (!SCM_IMP (obj)) + RECURSE (obj); + } + ptr = SCM_CCLO_REF (ptr, 0); + goto gc_mark_loop; + } +#endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: @@ -1078,22 +1292,15 @@ gc_mark_nimp: #endif #endif case scm_tc7_string: - SCM_SETGC8MARK (ptr); break; case scm_tc7_substring: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_wvect: - if (SCM_GC8MARKP(ptr)) - break; SCM_WVECT_GC_CHAIN (ptr) = scm_weak_vectors; scm_weak_vectors = ptr; - SCM_SETGC8MARK (ptr); if (SCM_IS_WHVEC_ANY (ptr)) { int x; @@ -1101,7 +1308,7 @@ gc_mark_nimp: int weak_keys; int weak_values; - len = SCM_LENGTH (ptr); + len = SCM_VECTOR_LENGTH (ptr); weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); @@ -1139,40 +1346,30 @@ gc_mark_nimp: * won't prematurely drop table entries. */ if (!weak_keys) - scm_gc_mark (SCM_CAR (kvpair)); + RECURSE (SCM_CAR (kvpair)); if (!weak_values) - scm_gc_mark (SCM_GCCDR (kvpair)); + RECURSE (SCM_CDR (kvpair)); alist = next_alist; } if (SCM_NIMP (alist)) - scm_gc_mark (alist); + RECURSE (alist); } } break; - case scm_tc7_msymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - scm_gc_mark (SCM_SYMBOL_FUNC (ptr)); - ptr = SCM_SYMBOL_PROPS (ptr); + case scm_tc7_symbol: + ptr = SCM_PROP_SLOTS (ptr); goto gc_mark_loop; - case scm_tc7_ssymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - break; 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; - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); + SCM_MISC_ERROR ("undefined port type", SCM_EOL); +#endif if (SCM_PTAB_ENTRY(ptr)) - scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); + RECURSE (SCM_FILENAME (ptr)); if (scm_ptobs[i].mark) { ptr = (scm_ptobs[i].mark) (ptr); @@ -1182,22 +1379,20 @@ gc_mark_nimp: return; break; case scm_tc7_smob: - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); - switch (SCM_GCTYP16 (ptr)) + 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); */ - case scm_tc16_allocated: 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); @@ -1208,9 +1403,27 @@ gc_mark_nimp: } break; default: - def:scm_wta (ptr, "unknown type in ", "gc_mark"); + SCM_MISC_ERROR ("unknown type", SCM_EOL); } +#undef RECURSE } +#undef FUNC_NAME + +#ifndef MARK_DEPENDENCIES + +#undef MARK +#undef FNAME + +/* And here we define `scm_gc_mark_dependencies', by including this + * same file in itself. + */ +#define MARK scm_gc_mark_dependencies +#define FNAME "scm_gc_mark_dependencies" +#define MARK_DEPENDENCIES +#include "gc.c" +#undef MARK_DEPENDENCIES +#undef MARK +#undef FNAME /* Mark a Region Conservatively @@ -1219,64 +1432,66 @@ gc_mark_nimp: void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) { - register long m = n; - register int i, j; - register SCM_CELLPTR ptr; + unsigned long m; - while (0 <= --m) - if (SCM_CELLP (* (SCM *) &x[m])) - { - ptr = SCM2PTR (* (SCM *) &x[m]); - i = 0; - 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) - { - 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 - { - 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; - } - } - if (!scm_heap_table[seg_id].valid - || scm_heap_table[seg_id].valid (ptr, - &scm_heap_table[seg_id])) - if (scm_heap_table[seg_id].span == 1 - || SCM_DOUBLE_CELLP (* (SCM *) &x[m])) - scm_gc_mark (* (SCM *) &x[m]); - break; - } + for (m = 0; m < n; ++m) + { + SCM obj = * (SCM *) &x[m]; + if (SCM_CELLP (obj)) + { + 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) + { + 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 + { + 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; + } + } - } - } + 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; + } + } + } + } } @@ -1292,6 +1507,9 @@ scm_cellp (SCM value) unsigned int i = 0; unsigned int j = scm_n_heap_segs - 1; + if (SCM_GC_IN_CARD_HEADERP (ptr)) + return 0; + while (i < j) { int k = (i + j) / 2; if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) { @@ -1301,17 +1519,16 @@ scm_cellp (SCM value) } } - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) + 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].valid || scm_heap_table[i].valid (ptr, &scm_heap_table[i])) - && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value))) { + && (scm_heap_table[i].span == 1 || DOUBLECELL_ALIGNED_P (value)) + && !SCM_GC_IN_CARD_HEADERP (ptr) + ) return 1; - } else { + else return 0; - } - } else { + } else return 0; - } } @@ -1332,11 +1549,11 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) { int collected; *freelist->clustertail = freelist->cells; - if (SCM_NNULLP (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); } @@ -1353,8 +1570,17 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) freelist->grow_heap_p = (collected < freelist->min_yield); } +#define NEXT_DATA_CELL(ptr, span) \ + do { \ + scm_cell *nxt__ = CELL_UP ((char *) (ptr) + 1, (span)); \ + (ptr) = (SCM_GC_IN_CARD_HEADERP (nxt__) ? \ + CELL_UP (SCM_GC_CELL_CARD (nxt__) + SCM_GC_CARD_N_HEADER_CELLS, span) \ + : nxt__); \ + } while (0) + void scm_gc_sweep () +#define FUNC_NAME "scm_gc_sweep" { register SCM_CELLPTR ptr; register SCM nfreelist; @@ -1387,151 +1613,129 @@ scm_gc_sweep () ptr = CELL_UP (scm_heap_table[i].bounds[0], span); seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr; + + /* use only data cells in seg_size */ + seg_size = (seg_size / SCM_GC_CARD_N_CELLS) * (SCM_GC_CARD_N_DATA_CELLS / span) * span; + + scm_gc_cells_swept += seg_size; + for (j = seg_size + span; j -= span; ptr += span) { - SCM scmptr = PTR2SCM (ptr); + SCM scmptr; - switch SCM_TYP7 (scmptr) + if (SCM_GC_IN_CARD_HEADERP (ptr)) { + SCM_CELLPTR nxt; + + /* cheat here */ + nxt = ptr; + NEXT_DATA_CELL (nxt, span); + j += span; + + ptr = nxt - span; + continue; + } + + scmptr = PTR2SCM (ptr); + + if (SCM_GCMARKP (scmptr)) + continue; + + switch SCM_TYP7 (scmptr) + { case scm_tcs_cons_gloc: { /* Dirk:FIXME:: Again, super ugly code: scmptr may be a * struct or a gloc. See the corresponding comment in * scm_gc_mark. */ - scm_bits_t word0 = SCM_CELL_WORD_0 (scmptr) - scm_tc3_cons_gloc; - scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */ - if (SCM_GCMARKP (scmptr)) - { - if (vtable_data [scm_vtable_index_vcell] == 1) - vtable_data [scm_vtable_index_vcell] = 0; - goto cmrkcontinue; - } - else + scm_bits_t word0 = (SCM_CELL_WORD_0 (scmptr) + - scm_tc3_cons_gloc); + /* access as struct */ + scm_bits_t * vtable_data = (scm_bits_t *) word0; + if (vtable_data[scm_vtable_index_vcell] == 0) { - if (vtable_data [scm_vtable_index_vcell] == 0 - || vtable_data [scm_vtable_index_vcell] == 1) - { - scm_struct_free_t free - = (scm_struct_free_t) vtable_data[scm_struct_i_free]; - m += free (vtable_data, (scm_bits_t *) SCM_UNPACK (SCM_GCCDR (scmptr))); - } + /* Structs need to be freed in a special order. + * This is handled by GC C hooks in struct.c. + */ + SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_structs_to_free); + scm_structs_to_free = scmptr; + continue; } + /* fall through so that scmptr gets collected */ } break; case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: case scm_tcs_closures: case scm_tc7_pws: - if (SCM_GCMARKP (scmptr)) - goto cmrkcontinue; break; case scm_tc7_wvect: - if (SCM_GC8MARKP (scmptr)) - { - goto c8mrkcontinue; - } - else - { - m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free ((char *)(SCM_VELTS (scmptr) - 2)); - break; - } - + m += (2 + SCM_VECTOR_LENGTH (scmptr)) * sizeof (SCM); + scm_must_free (SCM_VECTOR_BASE (scmptr) - 2); + break; case scm_tc7_vector: - case scm_tc7_lvector: + { + unsigned long int length = SCM_VECTOR_LENGTH (scmptr); + if (length > 0) + { + m += length * sizeof (scm_bits_t); + scm_must_free (SCM_VECTOR_BASE (scmptr)); + } + break; + } #ifdef CCLO case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); - freechars: - scm_must_free (SCM_CHARS (scmptr)); - /* SCM_SETCHARS(scmptr, 0);*/ + m += (SCM_CCLO_LENGTH (scmptr) * sizeof (SCM)); + scm_must_free (SCM_CCLO_BASE (scmptr)); break; +#endif #ifdef HAVE_ARRAYS case scm_tc7_bvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - goto freechars; + { + unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr); + if (length > 0) + { + m += sizeof (long) * ((length + SCM_LONG_BIT - 1) / SCM_LONG_BIT); + scm_must_free (SCM_BITVECTOR_BASE (scmptr)); + } + } + break; case scm_tc7_byvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (char); - goto freechars; case scm_tc7_ivect: case scm_tc7_uvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long); - goto freechars; case scm_tc7_svect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (short); - goto freechars; #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long); - goto freechars; #endif case scm_tc7_fvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (float); - goto freechars; case scm_tc7_dvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (double); - goto freechars; case scm_tc7_cvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); - goto freechars; + m += SCM_UVECTOR_LENGTH (scmptr) * scm_uniform_element_size (scmptr); + scm_must_free (SCM_UVECTOR_BASE (scmptr)); + break; #endif case scm_tc7_substring: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; break; case scm_tc7_string: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) + 1; - goto freechars; - case scm_tc7_msymbol: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += (SCM_LENGTH (scmptr) + 1 - + (SCM_CHARS (scmptr) - (char *) SCM_SLOTS (scmptr))); - scm_must_free ((char *)SCM_SLOTS (scmptr)); + m += SCM_STRING_LENGTH (scmptr) + 1; + scm_must_free (SCM_STRING_CHARS (scmptr)); break; - case scm_tc7_contin: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); - if (SCM_VELTS (scmptr)) - goto freechars; - case scm_tc7_ssymbol: - if SCM_GC8MARKP(scmptr) - goto c8mrkcontinue; + case scm_tc7_symbol: + m += SCM_SYMBOL_LENGTH (scmptr) + 1; + scm_must_free (SCM_SYMBOL_CHARS (scmptr)); break; case scm_tcs_subrs: + /* the various "subrs" (primitives) are never freed */ continue; case scm_tc7_port: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; 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; @@ -1542,53 +1746,46 @@ scm_gc_sweep () 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: - switch SCM_GCTYP16 (scmptr) + switch SCM_TYP16 (scmptr) { case scm_tc_free_cell: case scm_tc16_real: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; break; #ifdef SCM_BIGDIG case scm_tc16_big: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - goto freechars; + scm_must_free (SCM_BDIGITS (scmptr)); + break; #endif /* def SCM_BIGDIG */ case scm_tc16_complex: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += 2 * sizeof (double); - goto freechars; + m += sizeof (scm_complex_t); + scm_must_free (SCM_COMPLEX_MEM (scmptr)); + break; default: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - { 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_wta (scmptr, "unknown type in ", "gc_sweep"); + SCM_MISC_ERROR ("unknown type", SCM_EOL); } -#if 0 - if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) - exit (2); -#endif + if (!--left_to_collect) { - SCM_SETCAR (scmptr, nfreelist); + SCM_SET_CELL_WORD_0 (scmptr, nfreelist); *freelist->clustertail = scmptr; freelist->clustertail = SCM_CDRLOC (scmptr); @@ -1603,17 +1800,11 @@ scm_gc_sweep () conservative collector might trace it as some other type of object. */ SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, nfreelist); + SCM_SET_FREE_CELL_CDR (scmptr, nfreelist); nfreelist = scmptr; } - - continue; - c8mrkcontinue: - SCM_CLRGC8MARK (scmptr); - continue; - cmrkcontinue: - SCM_CLRGCMARK (scmptr); } + #ifdef GC_FREE_SEGMENTS if (n == seg_size) { @@ -1637,9 +1828,6 @@ scm_gc_sweep () } #ifdef GUILE_DEBUG_FREELIST - scm_check_freelist (freelist == &scm_master_freelist - ? scm_freelist - : scm_freelist2); scm_map_free_list (); #endif } @@ -1657,20 +1845,21 @@ scm_gc_sweep () scm_mallocated -= m; scm_gc_malloc_collected = m; } +#undef FUNC_NAME - /* {Front end to malloc} * - * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc + * 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. * @@ -1721,8 +1910,7 @@ scm_must_malloc (scm_sizet size, const char *what) return ptr; } - scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what); - return 0; /* never reached */ + scm_memory_error (what); } @@ -1770,12 +1958,13 @@ scm_must_realloc (void *where, return ptr; } - scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what); - return 0; /* never reached */ + scm_memory_error (what); } + void scm_must_free (void *obj) +#define FUNC_NAME "scm_must_free" { #ifdef GUILE_DEBUG_MALLOC scm_malloc_unregister (obj); @@ -1783,8 +1972,10 @@ scm_must_free (void *obj) if (obj) free (obj); else - scm_wta (SCM_INUM0, "already free", ""); + SCM_MISC_ERROR ("freeing NULL pointer", SCM_EOL); } +#undef FUNC_NAME + /* Announce that there has been some malloc done that will be freed * during gc. A typical use is for a smob that uses some malloced @@ -1792,7 +1983,13 @@ scm_must_free (void *obj) * reason). When a new object of this smob is created you call * scm_done_malloc with the size of the object. When your smob free * function is called, be sure to include this size in the return - * value. */ + * value. + * + * If you can't actually free the memory in the smob free function, + * for whatever reason (like reference counting), you still can (and + * should) report the amount of memory freed when you actually free it. + * Do it by calling scm_done_malloc with the _negated_ size. Clever, + * eh? Or even better, call scm_done_free. */ void scm_done_malloc (long size) @@ -1812,9 +2009,14 @@ scm_done_malloc (long size) } } +void +scm_done_free (long size) +{ + scm_mallocated -= size; +} - + /* {Heap Segments} * * Each heap segment is an array of objects of a particular size. @@ -1839,18 +2041,26 @@ scm_sizet scm_max_segment_size; 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; /* init_heap_seg - * initializes a new heap segment and return the number of objects it contains. + * initializes a new heap segment and returns the number of objects it contains. * - * The segment origin, segment size in bytes, and the span of objects - * in cells are input parameters. The freelist is both input and output. + * The segment origin and segment size in bytes are input parameters. + * The freelist is both input and output. * - * This function presume that the scm_heap_table has already been expanded - * to accomodate a new segment record. + * This function presumes that the scm_heap_table has already been expanded + * to accomodate a new segment record and that the markbit space was reserved + * for all the cards in this segment. */ +#define INIT_CARD(card, span) \ + do { \ + SCM_GC_SET_CARD_BVEC (card, get_bvec ()); \ + if ((span) == 2) \ + 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) @@ -1864,11 +2074,13 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) if (seg_org == NULL) return 0; - ptr = CELL_UP (seg_org, span); + /* Align the begin ptr up. + */ + ptr = SCM_GC_CARD_UP (seg_org); /* Compute the ceiling on valid object pointers w/in this segment. */ - seg_end = CELL_DN ((char *) seg_org + size, span); + seg_end = SCM_GC_CARD_DOWN ((char *)seg_org + size); /* Find the right place and insert the segment record. * @@ -1887,18 +2099,11 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) ++scm_n_heap_segs; - scm_heap_table[new_seg_index].valid = 0; scm_heap_table[new_seg_index].span = span; scm_heap_table[new_seg_index].freelist = freelist; scm_heap_table[new_seg_index].bounds[0] = ptr; scm_heap_table[new_seg_index].bounds[1] = seg_end; - - /* Compute the least valid object pointer w/in this segment - */ - ptr = CELL_UP (ptr, span); - - /*n_new_cells*/ n_new_cells = seg_end - ptr; @@ -1908,41 +2113,56 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) { SCM clusters; SCM *clusterp = &clusters; - int n_cluster_cells = span * freelist->cluster_size; - while (n_new_cells > span) /* at least one spine + one freecell */ + NEXT_DATA_CELL (ptr, span); + while (ptr < seg_end) { - /* Determine end of cluster - */ - if (n_new_cells >= n_cluster_cells) - { - seg_end = ptr + n_cluster_cells; - n_new_cells -= n_cluster_cells; - } - else - /* [cmm] looks like the segment size doesn't divide cleanly by - cluster size. bad cmm! */ - abort(); + scm_cell *nxt = ptr; + scm_cell *prv = NULL; + scm_cell *last_card = NULL; + int n_data_cells = (SCM_GC_CARD_N_DATA_CELLS / span) * SCM_CARDS_PER_CLUSTER - 1; + NEXT_DATA_CELL(nxt, span); /* Allocate cluster spine */ *clusterp = PTR2SCM (ptr); - SCM_SETCAR (*clusterp, PTR2SCM (ptr + span)); + SCM_SETCAR (*clusterp, PTR2SCM (nxt)); clusterp = SCM_CDRLOC (*clusterp); - ptr += span; + ptr = nxt; - while (ptr < seg_end) + while (n_data_cells--) { + scm_cell *card = SCM_GC_CELL_CARD (ptr); SCM scmptr = PTR2SCM (ptr); + nxt = ptr; + NEXT_DATA_CELL (nxt, span); + prv = ptr; + + if (card != last_card) + { + INIT_CARD (card, span); + last_card = card; + } SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (ptr + span)); - ptr += span; + SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt)); + + ptr = nxt; } - SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL); + SCM_SET_FREE_CELL_CDR (PTR2SCM (prv), SCM_EOL); } + /* sanity check */ + { + scm_cell *ref = seg_end; + NEXT_DATA_CELL (ref, span); + if (ref != ptr) + /* [cmm] looks like the segment size doesn't divide cleanly by + cluster size. bad cmm! */ + abort(); + } + /* Patch up the last cluster pointer in the segment * to join it to the input freelist. */ @@ -1967,31 +2187,51 @@ round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len) } static void -alloc_some_heap (scm_freelist_t *freelist) +alloc_some_heap (scm_freelist_t *freelist, policy_on_error error_policy) +#define FUNC_NAME "alloc_some_heap" { - scm_heap_seg_data_t * tmptable; SCM_CELLPTR ptr; long len; - /* Critical code sections (such as the garbage collector) - * aren't supposed to add heap segments. - */ if (scm_gc_heap_lock) - scm_wta (SCM_UNDEFINED, "need larger initial", "heap"); - - /* Expand the heap tables to have room for the new 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. - */ - len = (1 + scm_n_heap_segs) * sizeof (scm_heap_seg_data_t); - - SCM_SYSCALL (tmptable = ((scm_heap_seg_data_t *) - realloc ((char *)scm_heap_table, len))); - if (!tmptable) - scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); - else - scm_heap_table = tmptable; + { + /* Critical code sections (such as the garbage collector) aren't + * supposed to add heap segments. + */ + fprintf (stderr, "alloc_some_heap: Can not extend locked heap.\n"); + abort (); + } + if (scm_n_heap_segs == heap_segment_table_size) + { + /* We have to expand the heap segment table to have room for the new + * 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; + + SCM_SYSCALL (new_heap_table = ((scm_heap_seg_data_t *) + realloc ((char *)scm_heap_table, size))); + if (!new_heap_table) + { + if (error_policy == abort_on_error) + { + fprintf (stderr, "alloc_some_heap: Could not grow heap segment table.\n"); + abort (); + } + else + { + return; + } + } + else + { + scm_heap_table = new_heap_table; + heap_segment_table_size = new_table_size; + } + } /* Pick a size for the new heap segment. * The rule for picking the size of a segment is explained in @@ -2051,13 +2291,19 @@ alloc_some_heap (scm_freelist_t *freelist) } } - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); + if (error_policy == abort_on_error) + { + fprintf (stderr, "alloc_some_heap: Could not grow heap.\n"); + abort (); + } } +#undef FUNC_NAME SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, (SCM name), - "") + "Flushes the glocs for @var{name}, or all glocs if @var{name}\n" + "is @code{#t}.") #define FUNC_NAME s_scm_unhash_name { int x; @@ -2082,7 +2328,7 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, 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_TRUE_P (name) || SCM_EQ_P (SCM_CAR (gloc_car), name)) + 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); @@ -2102,10 +2348,59 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, */ +/* + * If within a function you need to protect one or more scheme objects from + * garbage collection, pass them as parameters to one of the + * scm_remember_upto_here* functions below. These functions don't do + * anything, but since the compiler does not know that they are actually + * no-ops, it will generate code that calls these functions with the given + * 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 + * depends on the scheme object to exist. + * + * Example: We want to make sure, that the string object str does not get + * garbage collected during the execution of 'some_function', because + * otherwise the characters belonging to str would be freed and + * 'some_function' might access freed memory. To make sure that the compiler + * keeps str alive on the stack or in a register such that it is visible to + * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the + * call to 'some_function'. Note that this would not be necessary if str was + * used anyway after the call to 'some_function'. + * char *chars = SCM_STRING_CHARS (str); + * some_function (chars); + * scm_remember_upto_here_1 (str); // str will be alive up to this point. + */ + +void +scm_remember_upto_here_1 (SCM obj) +{ + /* Empty. Protects a single object from garbage collection. */ +} + +void +scm_remember_upto_here_2 (SCM obj1, SCM obj2) +{ + /* Empty. Protects two objects from garbage collection. */ +} + +void +scm_remember_upto_here (SCM obj, ...) +{ + /* Empty. Protects any number of objects from garbage collection. */ +} + + +#if (SCM_DEBUG_DEPRECATED == 0) + void scm_remember (SCM *ptr) -{ /* empty */ } +{ + /* empty */ +} +#endif /* SCM_DEBUG_DEPRECATED == 0 */ /* These crazy functions prevent garbage collection @@ -2138,33 +2433,33 @@ scm_permanent_object (SCM obj) } -/* Protect OBJ from the garbage collector. OBJ will not be freed, - even if all other references are dropped, until someone applies - scm_unprotect_object to it. This function returns OBJ. +/* 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, + 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 + than it has been protected before. The function scm_protect_object returns + OBJ. +*/ - Calls to scm_protect_object nest. For every object OBJ, there is a - counter which scm_protect_object(OBJ) increments and - scm_unprotect_object(OBJ) decrements, if it is greater than zero. If - an object's counter is greater than zero, the garbage collector - will not free it. */ +/* Implementation note: For every object X, there is a counter which + scm_protect_object(X) increments and scm_unprotect_object(X) decrements. +*/ SCM scm_protect_object (SCM obj) { SCM handle; - + /* This critical section barrier will be replaced by a mutex. */ - SCM_DEFER_INTS; - - handle = scm_hashq_get_handle (scm_protects, obj); + 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_REALLOW_INTS; - if (SCM_IMP (handle)) - scm_hashq_create_handle_x (scm_protects, obj, SCM_MAKINUM (1)); - else - SCM_SETCDR (handle, SCM_MAKINUM (SCM_INUM (SCM_CDR (handle)) + 1)); - - SCM_ALLOW_INTS; - return obj; } @@ -2177,22 +2472,27 @@ SCM scm_unprotect_object (SCM obj) { SCM handle; - + /* This critical section barrier will be replaced by a mutex. */ - SCM_DEFER_INTS; - + SCM_REDEFER_INTS; + handle = scm_hashq_get_handle (scm_protects, obj); - if (SCM_NIMP (handle)) + if (SCM_FALSEP (handle)) + { + fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); + abort (); + } + else { - int count = SCM_INUM (SCM_CAR (handle)) - 1; - if (count <= 0) - scm_hashq_remove_x (scm_protects, obj); + unsigned long int count = SCM_INUM (SCM_CDR (handle)) - 1; + if (count == 0) + scm_hashq_remove_x (scm_protects, obj); else - SCM_SETCDR (handle, SCM_MAKINUM (count)); + SCM_SETCDR (handle, SCM_MAKINUM (count)); } - SCM_ALLOW_INTS; + SCM_REALLOW_INTS; return obj; } @@ -2223,6 +2523,7 @@ static int make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist) { scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size); + if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size), rounded_size, freelist)) @@ -2263,18 +2564,31 @@ init_freelist (scm_freelist_t *freelist, freelist->heap_size = 0; } + +/* Get an integer from an environment variable. */ +static int +scm_i_getenv_int (const char *var, int def) +{ + char *end, *val = getenv (var); + long res; + if (!val) + return def; + res = strtol (val, &end, 10); + if (end == val) + return def; + return res; +} + + int -scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, - scm_sizet init_heap_size_2, int gc_trigger_2, - scm_sizet max_segment_size) +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; - if (!init_heap_size_1) - init_heap_size_1 = SCM_INIT_HEAP_SIZE_1; - if (!init_heap_size_2) - init_heap_size_2 = SCM_INIT_HEAP_SIZE_2; - j = SCM_NUM_PROTECTS; while (j) scm_sys_protects[--j] = SCM_BOOL_F; @@ -2282,14 +2596,11 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, scm_freelist = SCM_EOL; scm_freelist2 = SCM_EOL; - init_freelist (&scm_master_freelist, - 1, SCM_CLUSTER_SIZE_1, - gc_trigger_1 ? gc_trigger_1 : SCM_MIN_YIELD_1); - init_freelist (&scm_master_freelist2, - 2, SCM_CLUSTER_SIZE_2, - gc_trigger_2 ? gc_trigger_2 : SCM_MIN_YIELD_2); - scm_max_segment_size - = max_segment_size ? max_segment_size : SCM_MAX_SEGMENT_SIZE; + gc_trigger_1 = scm_i_getenv_int ("GUILE_MIN_YIELD_1", scm_default_min_yield_1); + init_freelist (&scm_master_freelist, 1, SCM_CLUSTER_SIZE_1, gc_trigger_1); + gc_trigger_2 = scm_i_getenv_int ("GUILE_MIN_YIELD_2", scm_default_min_yield_2); + init_freelist (&scm_master_freelist2, 2, SCM_CLUSTER_SIZE_2, gc_trigger_2); + scm_max_segment_size = scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", scm_default_max_segment_size); scm_expmem = 0; @@ -2297,7 +2608,12 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, 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")); + heap_segment_table_size = 2; + mark_space_ptr = &mark_space_head; + + init_heap_size_1 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", scm_default_init_heap_size_1); + init_heap_size_2 = scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", scm_default_init_heap_size_2); if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || make_initial_segment (init_heap_size_2, &scm_master_freelist2)) return 1; @@ -2329,31 +2645,74 @@ scm_init_storage (scm_sizet init_heap_size_1, int gc_trigger_1, SCM_SETCDR (scm_undefineds, scm_undefineds); scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_nullstr = scm_makstr (0L, 0); - scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED); - scm_symhash = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); - scm_weak_symhash = scm_make_weak_key_hash_table (SCM_MAKINUM (scm_symhash_dim)); - scm_symhash_vars = scm_make_vector (SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + scm_nullstr = scm_allocate_string (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_make_vector (SCM_MAKINUM (31), SCM_EOL); - scm_asyncs = SCM_EOL; - scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); -#ifdef SCM_BIGDIG - scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); -#endif + scm_protects = scm_c_make_hash_table (31); + return 0; } + +SCM scm_after_gc_hook; + +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. + */ +static SCM +gc_async_thunk (void) +{ + scm_c_run_hook (scm_after_gc_hook, SCM_EOL); + return SCM_UNSPECIFIED; +} + + +/* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of + * the garbage collection. The only purpose of this function is to mark the + * gc_async (which will eventually lead to the execution of the + * gc_async_thunk). + */ +static void * +mark_gc_async (void * hook_data, void *func_data, void *data) +{ + scm_system_async_mark (gc_async); + return NULL; +} + + void scm_init_gc () { + SCM after_gc_thunk; + +#if (SCM_DEBUG_CELL_ACCESSES == 1) + scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); +#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ + scm_after_gc_hook = scm_create_hook ("after-gc-hook", 0); + + after_gc_thunk = scm_make_subr_opt ("%gc-thunk", scm_tc7_subr_0, gc_async_thunk, 0); + 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); + +#ifndef SCM_MAGIC_SNARFER #include "libguile/gc.x" +#endif } +#endif /*MARK_DEPENDENCIES*/ + /* Local Variables: c-file-style: "gnu"