* large heaps, especially if code behaviour is varying its
* maximum consumption between different freelists.
*/
-int scm_default_init_heap_size_1 = (45000L * sizeof (scm_cell));
+
+#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_1 2000L
-int scm_default_init_heap_size_2 = (2500L * 2 * sizeof (scm_cell));
+#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
*/
int scm_default_min_yield_2 = 40;
-#define SCM_CLUSTER_SIZE_2 1000L
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
#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 */
# 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 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)
\f
/* scm_freelists
*/
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.
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 ()
+{
+ 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_wta (SCM_UNDEFINED, "could not grow", "heap");
+
+ 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_wta (SCM_UNDEFINED, "could not grow", "heap");
+
+ 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;
+}
+
+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);
+}
+
+
\f
/* Debugging functions. */
}
}
-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"
"compile-time flag was selected.\n")
#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;
}
{
new = scm_freelist;
scm_freelist = SCM_FREE_CELL_CDR (scm_freelist);
- SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated);
}
return new;
{
new = scm_freelist2;
scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2);
- SCM_SET_FREE_CELL_TYPE (new, scm_tc16_allocated);
}
return new;
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;
++master->clusters_allocated;
}
while (SCM_NULLP (cell));
+
+#ifdef GUILE_DEBUG_FREELIST
+ scm_check_freelist (cell);
+#endif
+
--scm_ints_disabled;
*freelist = SCM_FREE_CELL_CDR (cell);
- SCM_SET_FREE_CELL_TYPE (cell, scm_tc16_allocated);
return cell;
}
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)
{
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);
#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]);
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
+
+ if (SCM_GCMARKP (ptr))
+ return;
+
+ SCM_SETGCMARK (ptr);
+
switch (SCM_TYP7 (ptr))
{
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);
+ 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);
+ ptr = SCM_CDR (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
scm_bits_t * vtable_data = (scm_bits_t *) word0; /* access as struct */
if (vtable_data [scm_vtable_index_vcell] != 0)
{
- /* ptr is a gloc */
- SCM gloc_car = SCM_PACK (word0);
- scm_gc_mark (gloc_car);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
- }
- else
- {
- /* 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));
- }
- }
- /* mark vtable */
- ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
- goto gc_mark_loop;
+ /* ptr is a gloc */
+ SCM gloc_car = SCM_PACK (word0);
+ scm_gc_mark (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)
+ {
+ 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));
+ }
+ }
+ /* 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)))
{
ptr = SCM_CLOSCAR (ptr);
goto gc_mark_nimp;
}
scm_gc_mark (SCM_CLOSCAR (ptr));
- ptr = SCM_GCCDR (ptr);
+ ptr = SCM_CDR (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)
scm_gc_mark (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))
+ scm_gc_mark (obj);
+ }
+ ptr = SCM_CCLO_REF (ptr, 0);
+ goto gc_mark_loop;
+ }
+#endif
#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
#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;
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);
if (!weak_keys)
scm_gc_mark (SCM_CAR (kvpair));
if (!weak_values)
- scm_gc_mark (SCM_GCCDR (kvpair));
+ scm_gc_mark (SCM_CDR (kvpair));
alist = next_alist;
}
if (SCM_NIMP (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 (!(i < scm_numptob))
goto def;
- if (SCM_GC8MARKP (ptr))
- break;
- SCM_SETGC8MARK (ptr);
if (SCM_PTAB_ENTRY(ptr))
- scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
+ scm_gc_mark (SCM_FILENAME (ptr));
if (scm_ptobs[i].mark)
{
ptr = (scm_ptobs[i].mark) (ptr);
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;
}
}
+
+ if (SCM_GC_IN_CARD_HEADERP (ptr))
+ break;
+
if (scm_heap_table[seg_id].span == 1
|| SCM_DOUBLE_CELLP (obj))
- {
- if (!SCM_FREE_CELL_P (obj))
- scm_gc_mark (obj);
- }
+ scm_gc_mark (obj);
+
break;
}
}
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 || SCM_DOUBLE_CELLP (value))) {
+ && (scm_heap_table[i].span == 1 || SCM_DOUBLE_CELLP (value))
+ && !SCM_GC_IN_CARD_HEADERP (ptr)
+ )
return 1;
- } else {
+ else
return 0;
- }
- } else {
+ } else
return 0;
- }
}
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"
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
- scm_tc3_cons_gloc);
/* access as struct */
scm_bits_t * vtable_data = (scm_bits_t *) word0;
- if (SCM_GCMARKP (scmptr))
- goto cmrkcontinue;
- else if (vtable_data[scm_vtable_index_vcell] == 0)
+ if (vtable_data[scm_vtable_index_vcell] == 0)
{
/* 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;
- goto cmrkcontinue;
+ continue;
}
/* fall through so that scmptr gets collected */
}
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);
}
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);
sweeperr:
SCM_MISC_ERROR ("unknown type", SCM_EOL);
}
-#if 0
- if (SCM_FREE_CELL_P (scmptr))
- exit (2);
-#endif
+
if (!--left_to_collect)
{
SCM_SETCAR (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)
{
}
#ifdef GUILE_DEBUG_FREELIST
- scm_check_freelist (freelist == &scm_master_freelist
- ? scm_freelist
- : scm_freelist2);
scm_map_free_list ();
#endif
}
\f
-
/* {Front end to malloc}
*
* scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
\f
-
/* {Heap Segments}
*
* Each heap segment is an array of objects of a particular size.
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_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)
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.
*
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;
{
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_SET_FREE_CELL_CDR (scmptr, PTR2SCM (ptr + span));
- ptr += span;
+ SCM_SETCDR (scmptr, PTR2SCM (nxt));
+
+ ptr = nxt;
}
- SCM_SET_FREE_CELL_CDR (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.
*/
}
}
-
/* Pick a size for the new heap segment.
* The rule for picking the size of a segment is explained in
* gc.h
void
scm_remember (SCM *ptr)
-{ /* empty */ }
+{
+ /* empty */
+}
/*
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))
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_default_init_heap_size_1;
- if (!init_heap_size_2)
- init_heap_size_2 = scm_default_init_heap_size_2;
-
j = SCM_NUM_PROTECTS;
while (j)
scm_sys_protects[--j] = SCM_BOOL_F;
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_default_min_yield_1);
- init_freelist (&scm_master_freelist2,
- 2, SCM_CLUSTER_SIZE_2,
- gc_trigger_2 ? gc_trigger_2 : scm_default_min_yield_2);
- scm_max_segment_size
- = max_segment_size ? max_segment_size : scm_default_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;
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;
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);
+
+#define DEFAULT_SYMHASH_SIZE 277
+ scm_symhash = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL);
+ scm_symbols = scm_make_weak_key_hash_table (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE));
+ scm_symhash_vars = scm_make_vector (SCM_MAKINUM (DEFAULT_SYMHASH_SIZE), SCM_EOL);
+
scm_stand_in_procs = SCM_EOL;
scm_permobjs = SCM_EOL;
scm_protects = scm_make_vector (SCM_MAKINUM (31), SCM_EOL);
#ifdef SCM_BIGDIG
scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD));
#endif
+
return 0;
}
#if (SCM_DEBUG_DEPRECATED == 0)
scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F);
#endif /* SCM_DEBUG_DEPRECATED == 0 */
- /* Dirk:FIXME:: We don't really want a binding here. */
- after_gc_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk);
- gc_async = scm_system_async (after_gc_thunk);
+ 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
}
/*
HCoop / bpt / guile.git / blobdiff