/* Copyright (C) 1995,1996 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 * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * 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. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * 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. */ #include #include "_scm.h" #include "stime.h" #include "stackchk.h" #include "struct.h" #include "genio.h" #include "weaks.h" #include "smob.h" #include "unif.h" #include "async.h" #include "gc.h" #ifdef HAVE_MALLOC_H #include #endif #ifdef HAVE_UNISTD_H #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} * * These are parameters for controlling memory allocation. The heap * is the area out of which scm_cons, and object headers are allocated. * * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a * 64 bit machine. The units of the _SIZE parameters are bytes. * Cons pairs and object headers occupy one heap cell. * * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is * allocated initially the heap will grow by half its current size * each subsequent time more heap is needed. * * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code * is in scm_init_storage() and alloc_some_heap() in sys.c * * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by * SCM_EXPHEAP(scm_heap_size) when more heap is needed. * * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap * is needed. * * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will * trigger a GC. */ #define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell)) #define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell)) #ifdef _QC # define SCM_HEAP_SEG_SIZE 32768L #else # ifdef sequent # define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell)) # else # define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell)) # endif #endif #define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2) #define SCM_INIT_MALLOC_LIMIT 100000 /* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner bounds for allocated storage */ #ifdef PROT386 /*in 386 protected mode we must only adjust the offset */ # define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7)) # define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p)) #else # ifdef _UNICOS # define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L)) # define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p)) # else # define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L)) # define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p)) # endif /* UNICOS */ #endif /* PROT386 */ /* scm_freelist * is the head of freelist of cons pairs. */ SCM scm_freelist = SCM_EOL; /* scm_mtrigger * is the number of bytes of must_malloc allocation needed to trigger gc. */ 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. */ int scm_gc_heap_lock = 0; /* GC Blocking * 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 (scm_heap_size/4) /* During collection, this accumulates objects holding * weak references. */ SCM *scm_weak_vectors; int scm_weak_size; int scm_n_weak; /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; unsigned long scm_mallocated = 0; unsigned long scm_gc_cells_collected; unsigned long scm_gc_malloc_collected; unsigned long scm_gc_ports_collected; unsigned long scm_gc_rt; unsigned long scm_gc_time_taken = 0; SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); SCM_SYMBOL (sym_heap_size, "cell-heap-size"); 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"); 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 */ int (*valid) (); }; 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 *)); /* {Scheme Interface to GC} */ SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats); SCM scm_gc_stats () { int i; int n; SCM heap_segs; SCM local_scm_mtrigger; SCM local_scm_mallocated; SCM local_scm_heap_size; SCM local_scm_cells_allocated; SCM local_scm_gc_time_taken; SCM answer; SCM_DEFER_INTS; scm_block_gc = 1; retry: heap_segs = SCM_EOL; n = scm_n_heap_segs; for (i = scm_n_heap_segs; i--; ) heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]), scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])), heap_segs); if (scm_n_heap_segs != n) goto retry; scm_block_gc = 0; local_scm_mtrigger = scm_mtrigger; local_scm_mallocated = scm_mallocated; local_scm_heap_size = scm_heap_size; local_scm_cells_allocated = scm_cells_allocated; local_scm_gc_time_taken = scm_gc_time_taken; 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_heap_segments, heap_segs), SCM_UNDEFINED); SCM_ALLOW_INTS; return answer; } void scm_gc_start (what) char *what; { scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); scm_gc_cells_collected = 0; scm_gc_malloc_collected = 0; scm_gc_ports_collected = 0; } void 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_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr); SCM scm_object_addr (obj) SCM obj; { return scm_ulong2num ((unsigned long)obj); } SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc); SCM scm_gc () { SCM_DEFER_INTS; scm_igc ("call"); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } /* {C Interface For When GC is Triggered} */ void scm_gc_for_alloc (ncells, freelistp) int ncells; SCM * freelistp; { SCM_REDEFER_INTS; scm_igc ("cells"); if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp)) { alloc_some_heap (ncells, freelistp); } SCM_REALLOW_INTS; } SCM scm_gc_for_newcell () { SCM fl; scm_gc_for_alloc (1, &scm_freelist); fl = scm_freelist; scm_freelist = SCM_CDR (fl); return fl; } void scm_igc (what) char *what; { int j; #ifdef USE_THREADS /* During the critical section, only the current thread may run. */ SCM_THREAD_CRITICAL_SECTION_START; #endif scm_gc_start (what); if (!scm_stack_base || scm_block_gc) { scm_gc_end (); return; } ++scm_gc_heap_lock; scm_n_weak = 0; /* 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); x = SCM_INUM (scm_continuation_stack_ptr); while (x < bound) { elts[x] = SCM_BOOL_F; ++x; } } #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. */ SCM_FLUSH_REGISTER_WINDOWS; /* 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))); { /* stack_len is long rather than scm_sizet in order to guarantee that &stack_len is long aligned */ #ifdef SCM_STACK_GROWS_UP #ifdef nosve long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base; #else long stack_len = scm_stack_size (scm_stack_base); #endif scm_mark_locations (scm_stack_base, (scm_sizet) stack_len); #else #ifdef nosve long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len); #else long stack_len = scm_stack_size (scm_stack_base); #endif scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len); #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. */ j = SCM_NUM_PROTECTS; while (j--) scm_gc_mark (scm_sys_protects[j]); #ifndef USE_THREADS scm_gc_mark (scm_root->handle); #endif scm_mark_weak_vector_spines (); scm_gc_sweep (); --scm_gc_heap_lock; scm_gc_end (); #ifdef USE_THREADS SCM_THREAD_CRITICAL_SECTION_END; #endif } /* {Mark/Sweep} */ /* Mark an object precisely. */ void scm_gc_mark (p) SCM p; { register long i; register SCM ptr; ptr = p; gc_mark_loop: if (SCM_IMP (ptr)) return; gc_mark_nimp: if (SCM_NCELLP (ptr)) scm_wta (ptr, "rogue pointer in ", "heap"); 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 */ { ptr = SCM_CAR (ptr); goto gc_mark_nimp; } scm_gc_mark (SCM_CAR (ptr)); ptr = SCM_GCCDR (ptr); goto gc_mark_nimp; case scm_tcs_cons_imcar: if (SCM_GCMARKP (ptr)) break; SCM_SETGCMARK (ptr); ptr = SCM_GCCDR (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: if (SCM_GCMARKP (ptr)) break; SCM_SETGCMARK (ptr); { SCM vcell; vcell = SCM_CAR (ptr) - 1L; switch (SCM_CDR (vcell)) { default: scm_gc_mark (vcell); ptr = SCM_GCCDR (ptr); goto gc_mark_loop; case 1: /* ! */ case 0: /* ! */ { SCM layout; SCM * vtable_data; int len; char * fields_desc; register SCM * mem; register int x; vtable_data = (SCM *)vcell; layout = vtable_data[scm_struct_i_layout]; len = SCM_LENGTH (layout); fields_desc = SCM_CHARS (layout); /* We're using SCM_GCCDR here like STRUCT_DATA, except that it removes the mark */ mem = (SCM *)SCM_GCCDR (ptr); 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]; 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); 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); if (i == 0) break; while (--i > 0) if (SCM_NIMP (SCM_VELTS (ptr)[i])) 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); scm_mark_locations (SCM_VELTS (ptr), (scm_sizet) (SCM_LENGTH (ptr) + sizeof (scm_contregs) / sizeof (SCM_STACKITEM))); break; case scm_tc7_bvect: case scm_tc7_byvect: case scm_tc7_ivect: case scm_tc7_uvect: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: case scm_tc7_svect: #ifdef LONGLONGS case scm_tc7_llvect: #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); ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_wvect: if (SCM_GC8MARKP(ptr)) break; scm_weak_vectors[scm_n_weak++] = ptr; if (scm_n_weak >= scm_weak_size) { SCM_SYSCALL (scm_weak_vectors = (SCM *) realloc ((char *) scm_weak_vectors, 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); exit(SCM_EXIT_FAILURE); } } SCM_SETGC8MARK (ptr); if (SCM_IS_WHVEC_ANY (ptr)) { int x; int len; int weak_keys; int weak_values; len = SCM_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); for (x = 0; x < len; ++x) { SCM alist; alist = SCM_VELTS (ptr)[x]; /* 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) && SCM_NIMP (SCM_CAR (alist)) && SCM_CONSP (SCM_CAR (alist))) { SCM kvpair; SCM next_alist; kvpair = SCM_CAR (alist); next_alist = SCM_CDR (alist); /* * Do not do this: * SCM_SETGCMARK (alist); * SCM_SETGCMARK (kvpair); * * It may be that either the key or value is protected by * an escaped reference to part of the spine of this alist. * If we mark the spine here, and only mark one or neither of the * key and value, they may never be properly marked. * This leads to a horrible situation in which an alist containing * freelist cells is exported. * * So only mark the spines of these arrays last of all marking. * If somebody confuses us by constructing a weak vector * with a circular alist then we are hosed, but at least we * won't prematurely drop table entries. */ if (!weak_keys) scm_gc_mark (SCM_CAR (kvpair)); if (!weak_values) scm_gc_mark (SCM_GCCDR (kvpair)); alist = next_alist; } if (SCM_NIMP (alist)) scm_gc_mark (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); goto gc_mark_loop; case scm_tc7_ssymbol: if (SCM_GC8MARKP(ptr)) break; SCM_SETGC8MARK (ptr); break; case scm_tcs_subrs: ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8)); goto gc_mark_loop; case scm_tc7_port: i = SCM_PTOBNUM (ptr); if (!(i < scm_numptob)) goto def; if (SCM_GC8MARKP (ptr)) break; if (SCM_PTAB_ENTRY(ptr)) scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); ptr = (scm_ptobs[i].mark) (ptr); goto gc_mark_loop; break; case scm_tc7_smob: if (SCM_GC8MARKP (ptr)) break; 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); */ SCM_SETGC8MARK (ptr); 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; } break; default: def:scm_wta (ptr, "unknown type in ", "gc_mark"); } } /* Mark a Region Conservatively */ void scm_mark_locations (x, n) SCM_STACKITEM x[]; scm_sizet n; { register long m = n; register int i, j; register SCM_CELLPTR ptr; while (0 <= --m) if SCM_CELLP (*(SCM **) & x[m]) { ptr = (SCM_CELLPTR) 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])) scm_gc_mark (*(SCM *) & x[m]); break; } } } } /* The following is a C predicate which determines if an SCM value can be regarded as a pointer to a cell on the heap. The code is duplicated from scm_mark_locations. */ int scm_cellp (value) SCM value; { register int i, j; register SCM_CELLPTR ptr; if SCM_CELLP (*(SCM **) & value) { ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); 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])) return 1; break; } } } return 0; } static void scm_mark_weak_vector_spines () { int i; for (i = 0; i < scm_n_weak; ++i) { if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) { SCM *ptr; SCM obj; int j; int n; obj = scm_weak_vectors[i]; ptr = SCM_VELTS (scm_weak_vectors[i]); n = SCM_LENGTH (scm_weak_vectors[i]); for (j = 0; j < n; ++j) { SCM alist; alist = ptr[j]; while ( SCM_NIMP (alist) && SCM_CONSP (alist) && !SCM_GCMARKP (alist) && SCM_NIMP (SCM_CAR (alist)) && SCM_CONSP (SCM_CAR (alist))) { SCM_SETGCMARK (alist); SCM_SETGCMARK (SCM_CAR (alist)); alist = SCM_GCCDR (alist); } } } } } void scm_gc_sweep () { register SCM_CELLPTR ptr; #ifdef SCM_POINTERS_MUNGED register SCM scmptr; #else #undef scmptr #define scmptr (SCM)ptr #endif register SCM nfreelist; register SCM *hp_freelist; register long n; register long m; register scm_sizet j; register int span; scm_sizet i; scm_sizet seg_size; n = 0; m = 0; i = 0; while (i < scm_n_heap_segs) { hp_freelist = scm_heap_table[i].freelistp; nfreelist = SCM_EOL; 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 scmptr = PTR2SCM (ptr); #endif switch SCM_TYP7 (scmptr) { case scm_tcs_cons_gloc: if (SCM_GCMARKP (scmptr)) { if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1) SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0); goto cmrkcontinue; } { SCM vcell; vcell = SCM_CAR (scmptr) - 1L; if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) { SCM *p = (SCM *) SCM_GCCDR (scmptr); m += p[scm_struct_i_n_words] * sizeof (SCM); /* 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: if (SCM_GCMARKP (scmptr)) goto cmrkcontinue; break; case scm_tc7_wvect: if (SCM_GC8MARKP (scmptr)) { goto c8mrkcontinue; } else { m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM); scm_must_free ((char *)(SCM_VELTS (scmptr) - 1)); break; } case scm_tc7_vector: case scm_tc7_lvector: #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);*/ break; 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; 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 LONGLONGS 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; 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; goto freechars; case scm_tc7_msymbol: if (SCM_GC8MARKP (scmptr)) goto c8mrkcontinue; m += ( SCM_LENGTH (scmptr) + 1 + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr))); scm_must_free ((char *)SCM_SLOTS (scmptr)); break; case scm_tc7_contin: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); goto freechars; case scm_tc7_ssymbol: if SCM_GC8MARKP(scmptr) goto c8mrkcontinue; break; case scm_tcs_subrs: continue; case scm_tc7_port: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; if SCM_OPENP (scmptr) { int k = SCM_PTOBNUM (scmptr); if (!(k < scm_numptob)) goto sweeperr; /* Keep "revealed" ports alive. */ if (scm_revealed_count(scmptr) > 0) continue; /* 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_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; SCM_SETAND_CAR (scmptr, ~SCM_OPN); } break; case scm_tc7_smob: switch SCM_GCTYP16 (scmptr) { case scm_tc_free_cell: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; break; #ifdef SCM_BIGDIG case scm_tcs_bignums: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); goto freechars; #endif /* def SCM_BIGDIG */ case scm_tc16_flo: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; switch ((int) (SCM_CAR (scmptr) >> 16)) { case (SCM_IMAG_PART | SCM_REAL_PART) >> 16: m += sizeof (double); case SCM_REAL_PART >> 16: case SCM_IMAG_PART >> 16: m += sizeof (double); goto freechars; case 0: break; default: goto sweeperr; } break; default: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; { int k; k = SCM_SMOBNUM (scmptr); if (!(k < scm_numsmob)) goto sweeperr; m += (scm_smobs[k].free) ((SCM) scmptr); break; } } break; default: sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep"); } n += span; #if 0 if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) exit (2); #endif 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); continue; cmrkcontinue: SCM_CLRGCMARK (scmptr); } #ifdef GC_FREE_SEGMENTS if (n == seg_size) { 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++) scm_heap_table[j - 1] = scm_heap_table[j]; scm_n_heap_segs -= 1; i -= 1; /* need to scan segment just moved. */ } else #endif /* ifdef GC_FREE_SEGMENTS */ *hp_freelist = nfreelist; scm_gc_cells_collected += n; n = 0; } /* Scan weak vectors. */ { SCM *ptr; for (i = 0; i < scm_n_weak; ++i) { if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) { ptr = SCM_VELTS (scm_weak_vectors[i]); n = SCM_LENGTH (scm_weak_vectors[i]); for (j = 0; j < n; ++j) if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j])) ptr[j] = SCM_BOOL_F; } else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ { SCM obj; obj = scm_weak_vectors[i]; ptr = SCM_VELTS (scm_weak_vectors[i]); n = SCM_LENGTH (scm_weak_vectors[i]); for (j = 0; j < n; ++j) { SCM * fixup; SCM alist; int weak_keys; int weak_values; weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); fixup = ptr + j; alist = *fixup; while (SCM_NIMP (alist) && SCM_CONSP (alist) && SCM_NIMP (SCM_CAR (alist)) && SCM_CONSP (SCM_CAR (alist))) { SCM key; SCM value; key = SCM_CAAR (alist); value = SCM_CDAR (alist); if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key)) || (weak_values && SCM_NIMP (value) && SCM_FREEP (value))) { *fixup = SCM_CDR (alist); } else fixup = SCM_CDRLOC (alist); alist = SCM_CDR (alist); } } } } } scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected); scm_mallocated -= m; scm_gc_malloc_collected = m; } /* {Front end to malloc} * * scm_must_malloc, scm_must_realloc, scm_must_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. */ /* scm_must_malloc * Return newly malloced storage or throw an error. * * The parameter WHAT is a string for error reporting. * If the threshold scm_mtrigger will be passed by this * allocation, or if the first call to malloc fails, * garbage collect -- on the presumption that some objects * using malloced storage may be collected. * * The limit scm_mtrigger may be raised by this allocation. */ char * scm_must_malloc (len, what) long len; char *what; { char *ptr; scm_sizet size = len; long nm = scm_mallocated + size; if (len != size) malerr: scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); if ((nm <= scm_mtrigger)) { SCM_SYSCALL (ptr = (char *) malloc (size)); if (NULL != ptr) { scm_mallocated = nm; 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; return ptr; } goto malerr; } /* scm_must_realloc * is similar to scm_must_malloc. */ char * scm_must_realloc (where, olen, len, what) char *where; long olen; long len; char *what; { char *ptr; scm_sizet size = len; long nm = scm_mallocated + size - olen; if (len != size) ralerr: scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); if ((nm <= scm_mtrigger)) { SCM_SYSCALL (ptr = (char *) realloc (where, size)); if (NULL != ptr) { scm_mallocated = nm; return ptr; } } scm_igc (what); nm = scm_mallocated + size - olen; SCM_SYSCALL (ptr = (char *) realloc (where, size)); if (NULL != ptr) { scm_mallocated = nm; if (nm > scm_mtrigger) scm_mtrigger = nm + nm / 2; return ptr; } goto ralerr; } void scm_must_free (obj) char *obj; { if (obj) free (obj); else scm_wta (SCM_INUM0, "already free", ""); } /* {Heap Segments} * * Each heap segment is an array of objects of a particular size. * Every segment has an associated (possibly shared) freelist. * 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). */ /* scm_expmem * is true if the first segment was smaller than INIT_HEAP_SEG. * If scm_expmem is set to one, subsequent segment allocations will * allocate segments of size SCM_EXPHEAP(scm_heap_size). */ int scm_expmem = 0; /* scm_heap_org * is the lowest base address of any heap segment. */ SCM_CELLPTR scm_heap_org; struct scm_heap_seg_data * scm_heap_table = 0; int scm_n_heap_segs = 0; /* scm_heap_size * is the total number of cells in heap segments. */ long scm_heap_size = 0; /* init_heap_seg * initializes a new heap segment and return 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. * * This function presume that the scm_heap_table has already been expanded * to accomodate a new segment record. */ static scm_sizet init_heap_seg (seg_org, size, ncells, freelistp) SCM_CELLPTR seg_org; scm_sizet size; int ncells; SCM *freelistp; { register SCM_CELLPTR ptr; #ifdef SCM_POINTERS_MUNGED register SCM scmptr; #else #undef scmptr #define scmptr ptr #endif SCM_CELLPTR seg_end; scm_sizet new_seg_index; scm_sizet n_new_objects; if (seg_org == NULL) return 0; ptr = seg_org; /* Compute the ceiling on valid object pointers w/in this segment. */ seg_end = CELL_DN ((char *) ptr + size); /* Find the right place and insert the segment record. * */ for (new_seg_index = 0; ( (new_seg_index < scm_n_heap_segs) && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)); new_seg_index++) ; { int i; for (i = scm_n_heap_segs; i > new_seg_index; --i) scm_heap_table[i] = scm_heap_table[i - 1]; } ++scm_n_heap_segs; scm_heap_table[new_seg_index].valid = 0; scm_heap_table[new_seg_index].ncells = ncells; scm_heap_table[new_seg_index].freelistp = freelistp; scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr; scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end; /* Compute the least valid object pointer w/in this segment */ ptr = CELL_UP (ptr); n_new_objects = seg_end - ptr; /* Prepend objects in this segment to the freelist. */ while (ptr < seg_end) { #ifdef SCM_POINTERS_MUNGED scmptr = PTR2SCM (ptr); #endif SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells)); ptr += ncells; } ptr -= ncells; /* Patch up the last freelist pointer in the segment * to join it to the input freelist. */ SCM_SETCDR (PTR2SCM (ptr), *freelistp); *freelistp = PTR2SCM (CELL_UP (seg_org)); scm_heap_size += (ncells * n_new_objects); return size; #ifdef scmptr #undef scmptr #endif } static void alloc_some_heap (ncells, freelistp) int ncells; SCM * freelistp; { struct scm_heap_seg_data * tmptable; SCM_CELLPTR ptr; scm_sizet 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 (struct scm_heap_seg_data); SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *) realloc ((char *)scm_heap_table, len))); if (!tmptable) scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); else scm_heap_table = tmptable; /* Pick a size for the new heap segment. * The rule for picking the size of a segment is explained in * gc.h */ if (scm_expmem) { len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)); if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len) len = 0; } else len = SCM_HEAP_SEG_SIZE; { scm_sizet smallest; smallest = (ncells * sizeof (scm_cell)); if (len < smallest) len = (ncells * sizeof (scm_cell)); /* Allocate with decaying ambition. */ while ((len >= SCM_MIN_HEAP_SEG_SIZE) && (len >= smallest)) { SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len)); if (ptr) { init_heap_seg (ptr, len, ncells, freelistp); return; } len /= 2; } } scm_wta (SCM_UNDEFINED, "could not grow", "heap"); } SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name); SCM scm_unhash_name (name) SCM name; { int x; int bound; SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name); SCM_DEFER_INTS; bound = scm_n_heap_segs; for (x = 0; x < bound; ++x) { SCM_CELLPTR p; SCM_CELLPTR pbound; p = (SCM_CELLPTR)scm_heap_table[x].bounds[0]; pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1]; while (p < pbound) { SCM incar; incar = p->car; if (1 == (7 & (int)incar)) { --incar; if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name)) && (SCM_CDR (incar) != 0) && (SCM_CDR (incar) != 1)) { p->car = name; } } ++p; } } SCM_ALLOW_INTS; return name; } /* {GC Protection Helper Functions} */ void 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; } SCM scm_permanent_object (obj) SCM obj; { SCM_REDEFER_INTS; scm_permobjs = scm_cons (obj, scm_permobjs); SCM_REALLOW_INTS; return obj; } int scm_init_storage (init_heap_size) long init_heap_size; { scm_sizet j; j = SCM_NUM_PROTECTS; while (j) scm_sys_protects[--j] = SCM_BOOL_F; scm_block_gc = 1; scm_freelist = SCM_EOL; scm_expmem = 0; j = SCM_HEAP_SEG_SIZE; scm_mtrigger = SCM_INIT_MALLOC_LIMIT; scm_heap_table = ((struct scm_heap_seg_data *) scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims")); if (0L == init_heap_size) init_heap_size = SCM_INIT_HEAP_SIZE; j = init_heap_size; if ((init_heap_size != j) || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) { j = SCM_HEAP_SEG_SIZE; if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) return 1; } else 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 *)))) return 1; /* Initialise the list of ports. */ scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table) * scm_port_table_room)); if (!scm_port_table) return 1; scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); SCM_SETCDR (scm_undefineds, scm_undefineds); scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); scm_nullstr = scm_makstr (0L, 0); scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED); scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); 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_stand_in_procs = SCM_EOL; scm_permobjs = 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)); #ifdef SCM_BIGDIG scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); #endif return 0; } void scm_init_gc () { #include "gc.x" }