X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/2e11a5778a0d3a34d27c381dbd51e168dcff5a55..e4cd0c0a445b688ee045a2e0993f2b9191cae1a1:/libguile/gc.c diff --git a/libguile/gc.c b/libguile/gc.c index edcb78491..d80e711ba 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1997, 1998 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 @@ -12,7 +12,8 @@ * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, + * Boston, MA 02111-1307 USA * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,11 +37,21 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ + * If you do not wish that, delete this exception notice. */ #include #include "_scm.h" +#include "stime.h" +#include "stackchk.h" +#include "struct.h" +#include "genio.h" +#include "weaks.h" +#include "guardians.h" +#include "smob.h" +#include "unif.h" +#include "async.h" + +#include "gc.h" #ifdef HAVE_MALLOC_H #include @@ -50,6 +61,14 @@ #include #endif +#ifdef __STDC__ +#include +#define var_start(x, y) va_start(x, y) +#else +#include +#define var_start(x, y) va_start(x) +#endif + /* {heap tuning parameters} * @@ -77,6 +96,12 @@ * * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will * trigger a GC. + * + * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be + * reclaimed by a GC triggered by must_malloc. If less than this is + * reclaimed, the trigger threshold is raised. [I don't know what a + * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to + * work around a oscillation that caused almost constant GC.] */ #define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell)) @@ -92,6 +117,7 @@ #endif #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2) #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 */ @@ -120,7 +146,7 @@ SCM scm_freelist = SCM_EOL; /* scm_mtrigger * is the number of bytes of must_malloc allocation needed to trigger gc. */ -long scm_mtrigger; +unsigned long scm_mtrigger; /* scm_gc_heap_lock @@ -168,19 +194,128 @@ SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); struct scm_heap_seg_data { - SCM_CELLPTR bounds[2]; /* lower and upper */ - SCM *freelistp; /* the value of this may be shared */ - int ncells; /* per object in this segment */ + /* lower and upper bounds of the segment */ + SCM_CELLPTR bounds[2]; + + /* address of the head-of-freelist pointer for this segment's cells. + All segments usually point to the same one, scm_freelist. */ + SCM *freelistp; + + /* number of SCM words per object in this segment */ + int ncells; + + /* 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) (); }; -static void scm_mark_weak_vector_spines PROTO ((void)); -static scm_sizet init_heap_seg PROTO ((SCM_CELLPTR, scm_sizet, int, SCM *)); -static void alloc_some_heap PROTO ((int, SCM *)); +static void scm_mark_weak_vector_spines SCM_P ((void)); +static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *)); +static void alloc_some_heap SCM_P ((int, SCM *)); + + + +/* Debugging functions. */ + +#ifdef DEBUG_FREELIST + +/* Return the number of the heap segment containing CELL. */ +static int +which_seg (SCM cell) +{ + int i; + + for (i = 0; i < scm_n_heap_segs; i++) + if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell) + && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell)) + return i; + fprintf (stderr, "which_seg: can't find segment containing cell %lx\n", + cell); + abort (); +} + + +SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list); +SCM +scm_map_free_list () +{ + int last_seg = -1, count = 0; + SCM f; + + fprintf (stderr, "%d segments total\n", scm_n_heap_segs); + for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f)) + { + int this_seg = which_seg (f); + + if (this_seg != last_seg) + { + if (last_seg != -1) + fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); + last_seg = this_seg; + count = 0; + } + count++; + } + if (last_seg != -1) + fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); + + fflush (stderr); + + return SCM_UNSPECIFIED; +} + + +/* Number of calls to SCM_NEWCELL since startup. */ +static unsigned long scm_newcell_count; + +/* Search freelist for anything that isn't marked as a free cell. + Abort if we find something. */ +static void +scm_check_freelist () +{ + SCM f; + int i = 0; + + for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++) + if (SCM_CAR (f) != (SCM) scm_tc_free_cell) + { + 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 +scm_debug_newcell (void) +{ + SCM new; + scm_newcell_count++; + if (scm_debug_check_freelist) + scm_check_freelist (); + + /* The rest of this is supposed to be identical to the SCM_NEWCELL + macro. */ + if (SCM_IMP (scm_freelist)) + new = scm_gc_for_newcell (); + else + { + new = scm_freelist; + scm_freelist = SCM_CDR (scm_freelist); + ++scm_cells_allocated; + } + + return new; +} + +#endif /* DEBUG_FREELIST */ @@ -234,7 +369,7 @@ scm_gc_stats () void scm_gc_start (what) - char *what; + const char *what; { scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); scm_gc_cells_collected = 0; @@ -247,13 +382,13 @@ scm_gc_end () { scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt; - scm_take_signal (SCM_GC_SIGNAL); + scm_system_async_mark (scm_gc_async); } -SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr); +SCM_PROC (s_object_address, "object-address", 1, 0, 0, scm_object_address); SCM -scm_object_addr (obj) +scm_object_address (obj) SCM obj; { return scm_ulong2num ((unsigned long)obj); @@ -302,10 +437,17 @@ scm_gc_for_newcell () void scm_igc (what) - char *what; + const char *what; { int j; +#ifdef USE_THREADS + /* During the critical section, only the current thread may run. */ + SCM_THREAD_CRITICAL_SECTION_START; +#endif + + /* fprintf (stderr, "gc: %s\n", what); */ + scm_gc_start (what); if (!scm_stack_base || scm_block_gc) { @@ -316,6 +458,8 @@ scm_igc (what) ++scm_gc_heap_lock; scm_n_weak = 0; + scm_guardian_gc_init (); + /* unprotect any struct types with no instances */ #if 0 { @@ -327,7 +471,7 @@ scm_igc (what) while (type_list != SCM_EOL) if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt]) { - pos = &SCM_CDR (type_list); + pos = SCM_CDRLOC (type_list); type_list = SCM_CDR (type_list); } else @@ -353,6 +497,8 @@ scm_igc (what) } } +#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 @@ -365,8 +511,9 @@ scm_igc (what) /* This assumes that all registers are saved into the jmp_buf */ setjmp (scm_save_regs_gc_mark); scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ( (scm_sizet) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); + ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 + + sizeof scm_save_regs_gc_mark) + / sizeof (SCM_STACKITEM))); { /* stack_len is long rather than scm_sizet in order to guarantee that @@ -388,6 +535,12 @@ scm_igc (what) #endif } +#else /* USE_THREADS */ + + /* Mark every thread's stack and registers */ + scm_threads_mark_stacks(); + +#endif /* USE_THREADS */ /* FIXME: insert a phase to un-protect string-data preserved * in scm_vector_set_length_x. @@ -397,27 +550,22 @@ scm_igc (what) while (j--) scm_gc_mark (scm_sys_protects[j]); - scm_gc_mark (scm_rootcont); - scm_gc_mark (scm_dynwinds); - scm_gc_mark (scm_continuation_stack); - scm_gc_mark (scm_continuation_stack_ptr); - scm_gc_mark (scm_progargs); - scm_gc_mark (scm_exitval); - scm_gc_mark (scm_cur_inp); - scm_gc_mark (scm_cur_outp); - scm_gc_mark (scm_cur_errp); - scm_gc_mark (scm_def_inp); - scm_gc_mark (scm_def_outp); - scm_gc_mark (scm_def_errp); - scm_gc_mark (scm_top_level_lookup_thunk_var); - scm_gc_mark (scm_system_transformer); +#ifndef USE_THREADS + scm_gc_mark (scm_root->handle); +#endif scm_mark_weak_vector_spines (); + scm_guardian_zombify (); + scm_gc_sweep (); --scm_gc_heap_lock; scm_gc_end (); + +#ifdef USE_THREADS + SCM_THREAD_CRITICAL_SECTION_END; +#endif } @@ -443,7 +591,7 @@ gc_mark_loop: gc_mark_nimp: if (SCM_NCELLP (ptr)) - scm_wta (ptr, "rogue pointer in ", "heap"); + scm_wta (ptr, "rogue pointer in heap", NULL); switch (SCM_TYP7 (ptr)) { @@ -460,6 +608,7 @@ gc_mark_nimp: ptr = SCM_GCCDR (ptr); goto gc_mark_nimp; case scm_tcs_cons_imcar: + case scm_tc7_pws: if (SCM_GCMARKP (ptr)) break; SCM_SETGCMARK (ptr); @@ -485,22 +634,43 @@ gc_mark_nimp: SCM * vtable_data; int len; char * fields_desc; - SCM * mem; - int x; + register SCM * mem; + register int x; vtable_data = (SCM *)vcell; - layout = vtable_data[scm_struct_i_layout]; + layout = vtable_data[scm_vtable_index_layout]; len = SCM_LENGTH (layout); fields_desc = SCM_CHARS (layout); - mem = (SCM *)SCM_GCCDR (ptr); /* like struct_data but removes mark */ + /* We're using SCM_GCCDR here like STRUCT_DATA, except + that it removes the mark */ + mem = (SCM *)SCM_GCCDR (ptr); - for (x = 0; x < len; x += 2) - if (fields_desc[x] == 'p') - scm_gc_mark (mem[x / 2]); + if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + { + scm_gc_mark (mem[scm_struct_i_proc + 0]); + scm_gc_mark (mem[scm_struct_i_proc + 1]); + scm_gc_mark (mem[scm_struct_i_proc + 2]); + scm_gc_mark (mem[scm_struct_i_proc + 3]); + scm_gc_mark (mem[scm_struct_i_setter]); + } + if (len) + { + for (x = 0; x < len - 2; x += 2, ++mem) + if (fields_desc[x] == 'p') + scm_gc_mark (*mem); + if (fields_desc[x] == 'p') + { + if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) + for (x = *mem; x; --x) + scm_gc_mark (*++mem); + else + scm_gc_mark (*mem); + } + } if (!SCM_CDR (vcell)) { SCM_SETGCMARK (vcell); - ptr = vtable_data[scm_struct_i_vtable]; + ptr = vtable_data[scm_vtable_index_vtable]; goto gc_mark_loop; } } @@ -539,8 +709,13 @@ gc_mark_nimp: if SCM_GC8MARKP (ptr) break; SCM_SETGC8MARK (ptr); - scm_mark_locations (SCM_VELTS (ptr), - (scm_sizet) (SCM_LENGTH (ptr) + sizeof (regs) / sizeof (SCM_STACKITEM))); + if (SCM_VELTS (ptr)) + scm_mark_locations (SCM_VELTS (ptr), + (scm_sizet) + (SCM_LENGTH (ptr) + + (sizeof (SCM_STACKITEM) + -1 + + sizeof (scm_contregs)) / + sizeof (SCM_STACKITEM))); break; case scm_tc7_bvect: case scm_tc7_byvect: @@ -555,12 +730,10 @@ gc_mark_nimp: #endif case scm_tc7_string: - case scm_tc7_mb_string: SCM_SETGC8MARK (ptr); break; case scm_tc7_substring: - case scm_tc7_mb_substring: if (SCM_GC8MARKP(ptr)) break; SCM_SETGC8MARK (ptr); @@ -575,15 +748,12 @@ gc_mark_nimp: { SCM_SYSCALL (scm_weak_vectors = (SCM *) realloc ((char *) scm_weak_vectors, - sizeof (SCM *) * (scm_weak_size *= 2))); + sizeof (SCM) * (scm_weak_size *= 2))); if (scm_weak_vectors == NULL) { - scm_gen_puts (scm_regular_string, - "weak vector table", - scm_cur_errp); - scm_gen_puts (scm_regular_string, - "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n", - scm_cur_errp); + scm_puts ("weak vector table", scm_cur_errp); + scm_puts ("\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n", + scm_cur_errp); exit(SCM_EXIT_FAILURE); } } @@ -603,9 +773,9 @@ gc_mark_nimp: { SCM alist; alist = SCM_VELTS (ptr)[x]; - /* mark everything on the alist - * except the keys or values, according to weak_values and weak_keys. - */ + + /* mark everything on the alist except the keys or + * values, according to weak_values and weak_keys. */ while ( SCM_NIMP (alist) && SCM_CONSP (alist) && !SCM_GCMARKP (alist) @@ -667,31 +837,41 @@ gc_mark_nimp: goto def; if (SCM_GC8MARKP (ptr)) break; + SCM_SETGC8MARK (ptr); if (SCM_PTAB_ENTRY(ptr)) scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); - ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; + if (scm_ptobs[i].mark) + { + ptr = (scm_ptobs[i].mark) (ptr); + goto gc_mark_loop; + } + else + return; break; case scm_tc7_smob: if (SCM_GC8MARKP (ptr)) break; - switch SCM_TYP16 (ptr) + SCM_SETGC8MARK (ptr); + switch SCM_GCTYP16 (ptr) { /* should be faster than going through scm_smobs */ case scm_tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ - SCM_SETGC8MARK (ptr); - SCM_CDR (ptr) = SCM_EOL; + SCM_SETCDR (ptr, SCM_EOL); break; case scm_tcs_bignums: case scm_tc16_flo: - SCM_SETGC8MARK (ptr); break; default: i = SCM_SMOBNUM (ptr); if (!(i < scm_numsmob)) goto def; - ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; + if (scm_smobs[i].mark) + { + ptr = (scm_smobs[i].mark) (ptr); + goto gc_mark_loop; + } + else + return; } break; default: @@ -771,14 +951,10 @@ scm_mark_locations (x, n) regarded as a pointer to a cell on the heap. The code is duplicated from scm_mark_locations. */ -#ifdef __STDC__ -int -scm_cellp (SCM value) -#else + int scm_cellp (value) SCM value; -#endif { register int i, j; register SCM_CELLPTR ptr; @@ -889,25 +1065,35 @@ scm_gc_sweep () #endif register SCM nfreelist; register SCM *hp_freelist; - register long n; register long m; - register scm_sizet j; register int span; - scm_sizet i; + long i; scm_sizet seg_size; - n = 0; m = 0; - i = 0; - while (i < scm_n_heap_segs) + /* Reset all free list pointers. We'll reconstruct them completely + while scanning. */ + for (i = 0; i < scm_n_heap_segs; i++) + *scm_heap_table[i].freelistp = SCM_EOL; + + for (i = 0; i < scm_n_heap_segs; i++) { + register scm_sizet n = 0; + register scm_sizet j; + + /* Unmarked cells go onto the front of the freelist this heap + segment points to. Rather than updating the real freelist + pointer as we go along, we accumulate the new head in + nfreelist. Then, if it turns out that the entire segment is + free, we free (i.e., malloc's free) the whole segment, and + simply don't assign nfreelist back into the real freelist. */ hp_freelist = scm_heap_table[i].freelistp; - nfreelist = SCM_EOL; + nfreelist = *hp_freelist; + span = scm_heap_table[i].ncells; ptr = CELL_UP (scm_heap_table[i].bounds[0]); seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr; - ++i; for (j = seg_size + span; j -= span; ptr += span) { #ifdef SCM_POINTERS_MUNGED @@ -919,7 +1105,7 @@ scm_gc_sweep () if (SCM_GCMARKP (scmptr)) { if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1) - SCM_CDR (SCM_CAR (scmptr) - 1) = (SCM)0; + SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0); goto cmrkcontinue; } { @@ -928,18 +1114,27 @@ scm_gc_sweep () if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) { - SCM * mem; - SCM amt; - mem = (SCM *)SCM_CDR (scmptr); - amt = mem[-2]; - free (mem - 2); - m += amt * sizeof (SCM); + SCM *p = (SCM *) SCM_GCCDR (scmptr); + if (((SCM*) vcell)[scm_struct_i_flags] + & SCM_STRUCTF_LIGHT) + { + SCM layout = ((SCM*)vcell)[scm_vtable_index_layout]; + m += (SCM_LENGTH (layout) / 2) * sizeof (SCM); + free ((char *) p); + } + else + { + m += p[scm_struct_i_n_words] * sizeof (SCM) + 7; + /* I feel like I'm programming in BCPL here... */ + free ((char *) p[scm_struct_i_ptr]); + } } } 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; @@ -1012,12 +1207,10 @@ scm_gc_sweep () m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); goto freechars; case scm_tc7_substring: - case scm_tc7_mb_substring: if (SCM_GC8MARKP (scmptr)) goto c8mrkcontinue; break; case scm_tc7_string: - case scm_tc7_mb_string: if (SCM_GC8MARKP (scmptr)) goto c8mrkcontinue; m += SCM_HUGE_LENGTH (scmptr) + 1; @@ -1033,8 +1226,9 @@ scm_gc_sweep () case scm_tc7_contin: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; - m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (regs); - goto freechars; + 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; @@ -1055,11 +1249,11 @@ scm_gc_sweep () /* Yes, I really do mean scm_ptobs[k].free */ /* rather than ftobs[k].close. .close */ /* is for explicit CLOSE-PORT by user */ - (scm_ptobs[k].free) (SCM_STREAM (scmptr)); + (scm_ptobs[k].free) (scmptr); SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; - SCM_CAR (scmptr) &= ~SCM_OPN; + SCM_SETAND_CAR (scmptr, ~SCM_OPN); } break; case scm_tc7_smob: @@ -1115,14 +1309,14 @@ scm_gc_sweep () if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) exit (2); #endif - SCM_CAR (scmptr) = (SCM) scm_tc_free_cell; - SCM_CDR (scmptr) = nfreelist; + /* Stick the new cell on the front of nfreelist. It's + critical that we mark this cell as freed; otherwise, the + conservative collector might trace it as some other type + of object. */ + SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); + SCM_SETCDR (scmptr, nfreelist); nfreelist = scmptr; -#if 0 - if ((nfreelist < scm_heap_table[0].bounds[0]) || - (nfreelist >= scm_heap_table[0].bounds[1])) - exit (1); -#endif + continue; c8mrkcontinue: SCM_CLRGC8MARK (scmptr); @@ -1133,20 +1327,28 @@ scm_gc_sweep () #ifdef GC_FREE_SEGMENTS if (n == seg_size) { + register long j; + scm_heap_size -= seg_size; - free ((char *) scm_heap_table[i - 1].bounds[0]); - scm_heap_table[i - 1].bounds[0] = 0; - for (j = i; j < scm_n_heap_segs; j++) + free ((char *) scm_heap_table[i].bounds[0]); + scm_heap_table[i].bounds[0] = 0; + for (j = i + 1; j < scm_n_heap_segs; j++) scm_heap_table[j - 1] = scm_heap_table[j]; scm_n_heap_segs -= 1; - i -= 1; /* need to scan segment just moved. */ + i--; /* We need to scan the segment just moved. */ } else #endif /* ifdef GC_FREE_SEGMENTS */ + /* Update the real freelist pointer to point to the head of + the list of free cells we've built for this segment. */ *hp_freelist = nfreelist; +#ifdef DEBUG_FREELIST + scm_check_freelist (); + scm_map_free_list (); +#endif + scm_gc_cells_collected += n; - n = 0; } /* Scan weak vectors. */ { @@ -1155,6 +1357,8 @@ scm_gc_sweep () { if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) { + register long j, n; + ptr = SCM_VELTS (scm_weak_vectors[i]); n = SCM_LENGTH (scm_weak_vectors[i]); for (j = 0; j < n; ++j) @@ -1163,10 +1367,12 @@ scm_gc_sweep () } else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ { - SCM obj; - obj = scm_weak_vectors[i]; + SCM obj = scm_weak_vectors[i]; + register long n = SCM_LENGTH (scm_weak_vectors[i]); + register long j; + ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); + for (j = 0; j < n; ++j) { SCM * fixup; @@ -1196,7 +1402,7 @@ scm_gc_sweep () *fixup = SCM_CDR (alist); } else - fixup = &SCM_CDR (alist); + fixup = SCM_CDRLOC (alist); alist = SCM_CDR (alist); } } @@ -1213,7 +1419,7 @@ scm_gc_sweep () /* {Front end to malloc} * - * scm_must_malloc, scm_must_realloc, scm_must_free + * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc * * These functions provide services comperable to malloc, realloc, and * free. They are for allocating malloced parts of scheme objects. @@ -1233,12 +1439,12 @@ scm_gc_sweep () */ char * scm_must_malloc (len, what) - long len; - char *what; + scm_sizet len; + const char *what; { char *ptr; scm_sizet size = len; - long nm = scm_mallocated + size; + unsigned long nm = scm_mallocated + size; if (len != size) malerr: scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); @@ -1251,14 +1457,19 @@ scm_must_malloc (len, what) return ptr; } } + scm_igc (what); nm = scm_mallocated + size; SCM_SYSCALL (ptr = (char *) malloc (size)); if (NULL != ptr) { scm_mallocated = nm; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; + if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { + if (nm > scm_mtrigger) + scm_mtrigger = nm + nm / 2; + else + scm_mtrigger += scm_mtrigger / 2; + } return ptr; } goto malerr; @@ -1269,15 +1480,14 @@ scm_must_malloc (len, what) * is similar to scm_must_malloc. */ char * -scm_must_realloc (where, olen, len, what) - char *where; - long olen; - long len; - char *what; +scm_must_realloc (char *where, + scm_sizet olen, + scm_sizet len, + const char *what) { char *ptr; scm_sizet size = len; - long nm = scm_mallocated + size - olen; + scm_sizet nm = scm_mallocated + size - olen; if (len != size) ralerr: scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); @@ -1296,8 +1506,12 @@ scm_must_realloc (where, olen, len, what) if (NULL != ptr) { scm_mallocated = nm; - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; + if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { + if (nm > scm_mtrigger) + scm_mtrigger = nm + nm / 2; + else + scm_mtrigger += scm_mtrigger / 2; + } return ptr; } goto ralerr; @@ -1312,9 +1526,36 @@ scm_must_free (obj) else scm_wta (SCM_INUM0, "already free", ""); } - + +/* 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 + * memory but can not get it from scm_must_malloc (for whatever + * 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. */ + +void +scm_done_malloc (size) + long size; +{ + scm_mallocated += size; + + if (scm_mallocated > scm_mtrigger) + { + scm_igc ("foreign mallocs"); + if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) + { + if (scm_mallocated > scm_mtrigger) + scm_mtrigger = scm_mallocated + scm_mallocated / 2; + else + scm_mtrigger += scm_mtrigger / 2; + } + } +} + /* {Heap Segments} * @@ -1323,8 +1564,7 @@ scm_must_free (obj) * A table of segment records is kept that records the upper and * lower extents of the segment; this is used during the conservative * phase of gc to identify probably gc roots (because they point - * into valid segments at reasonable offsets). - */ + * into valid segments at reasonable offsets). */ /* scm_expmem * is true if the first segment was smaller than INIT_HEAP_SEG. @@ -1344,7 +1584,7 @@ int scm_n_heap_segs = 0; /* scm_heap_size * is the total number of cells in heap segments. */ -long scm_heap_size = 0; +unsigned long scm_heap_size = 0; /* init_heap_seg * initializes a new heap segment and return the number of objects it contains. @@ -1372,8 +1612,8 @@ init_heap_seg (seg_org, size, ncells, freelistp) #define scmptr ptr #endif SCM_CELLPTR seg_end; - scm_sizet new_seg_index; - scm_sizet n_new_objects; + int new_seg_index; + int n_new_objects; if (seg_org == NULL) return 0; @@ -1422,8 +1662,8 @@ init_heap_seg (seg_org, size, ncells, freelistp) #ifdef SCM_POINTERS_MUNGED scmptr = PTR2SCM (ptr); #endif - SCM_CAR (scmptr) = (SCM) scm_tc_free_cell; - SCM_CDR (scmptr) = PTR2SCM (ptr + ncells); + SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); + SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells)); ptr += ncells; } @@ -1432,7 +1672,7 @@ init_heap_seg (seg_org, size, ncells, freelistp) /* Patch up the last freelist pointer in the segment * to join it to the input freelist. */ - SCM_CDR (PTR2SCM (ptr)) = *freelistp; + SCM_SETCDR (PTR2SCM (ptr), *freelistp); *freelistp = PTR2SCM (CELL_UP (seg_org)); scm_heap_size += (ncells * n_new_objects); @@ -1559,15 +1799,9 @@ scm_remember (ptr) SCM * ptr; {} -#ifdef __STDC__ + SCM scm_return_first (SCM elt, ...) -#else -SCM -scm_return_first (elt, va_alist) - SCM elt; - va_dcl -#endif { return elt; } @@ -1584,10 +1818,58 @@ scm_permanent_object (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. + + Calls to scm_protect_object nest. For every object O, there is a + counter which scm_protect_object(O) increments and + scm_unprotect_object(O) decrements, if it is greater than zero. If + an object's counter is greater than zero, the garbage collector + will not free it. + + Of course, that's not how it's implemented. scm_protect_object and + scm_unprotect_object just maintain a list of references to things. + Since the GC knows about this list, all objects it mentions stay + alive. scm_protect_object adds its argument to the list; + scm_unprotect_object removes the first occurrence of its argument + to the list. */ +SCM +scm_protect_object (obj) + SCM obj; +{ + scm_protects = scm_cons (obj, scm_protects); + + return obj; +} + + +/* Remove any protection for OBJ established by a prior call to + scm_protect_object. This function returns OBJ. + + See scm_protect_object for more information. */ +SCM +scm_unprotect_object (obj) + SCM obj; +{ + SCM *tail_ptr = &scm_protects; + + while (SCM_NIMP (*tail_ptr) && SCM_CONSP (*tail_ptr)) + if (SCM_CAR (*tail_ptr) == obj) + { + *tail_ptr = SCM_CDR (*tail_ptr); + break; + } + else + tail_ptr = SCM_CDRLOC (*tail_ptr); + + return obj; +} + + int -scm_init_storage (init_heap_size) - long init_heap_size; +scm_init_storage (scm_sizet init_heap_size) { scm_sizet j; @@ -1616,7 +1898,7 @@ scm_init_storage (init_heap_size) scm_expmem = 1; scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]); /* scm_hplims[0] can change. do not remove scm_heap_org */ - if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *)))) + if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM)))) return 1; /* Initialise the list of ports. */ @@ -1627,15 +1909,17 @@ scm_init_storage (init_heap_size) scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); - SCM_CDR (scm_undefineds) = scm_undefineds; + 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_UNDEFINED); - scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); + scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED); + scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL); scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim)); - scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); + scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL); + scm_stand_in_procs = SCM_EOL; scm_permobjs = SCM_EOL; + scm_protects = SCM_EOL; scm_asyncs = SCM_EOL; scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));