-/* 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
*
* 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.
*
* 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. */
\f
#include <stdio.h>
#include "_scm.h"
#include "struct.h"
#include "genio.h"
#include "weaks.h"
+#include "guardians.h"
#include "smob.h"
#include "unif.h"
#include "async.h"
*
* 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))
#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 */
/* 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
}
static int scm_debug_check_freelist = 0;
-void
-scm_debug_newcell (SCM *into)
+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))
- *into = scm_gc_for_newcell ();
+ new = scm_gc_for_newcell ();
else
{
- *into = scm_freelist;
+ new = scm_freelist;
scm_freelist = SCM_CDR (scm_freelist);
++scm_cells_allocated;
}
+
+ return new;
}
#endif /* DEBUG_FREELIST */
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;
{
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);
void
scm_igc (what)
- char *what;
+ const char *what;
{
int j;
SCM_THREAD_CRITICAL_SECTION_START;
#endif
+ /* fprintf (stderr, "gc: %s\n", what); */
+
scm_gc_start (what);
if (!scm_stack_base || scm_block_gc)
{
++scm_gc_heap_lock;
scm_n_weak = 0;
+ scm_guardian_gc_init ();
+
/* unprotect any struct types with no instances */
#if 0
{
/* 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
scm_mark_weak_vector_spines ();
+ scm_guardian_zombify ();
+
scm_gc_sweep ();
--scm_gc_heap_lock;
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))
{
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);
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);
/* We're using SCM_GCCDR here like STRUCT_DATA, except
that it removes the mark */
mem = (SCM *)SCM_GCCDR (ptr);
+ 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 (!SCM_CDR (vcell))
{
SCM_SETGCMARK (vcell);
- ptr = vtable_data[scm_struct_i_vtable];
+ ptr = vtable_data[scm_vtable_index_vtable];
goto gc_mark_loop;
}
}
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)));
+ 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:
#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);
{
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);
}
}
{
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)
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_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:
#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;
/* Reset all free list pointers. We'll reconstruct them completely
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
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]);
+ 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;
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;
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
- goto freechars;
+ if (SCM_VELTS (scmptr))
+ goto freechars;
case scm_tc7_ssymbol:
if SCM_GC8MARKP(scmptr)
goto c8mrkcontinue;
/* 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++;
if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
exit (2);
#endif
- /* Stick the new cell on the front of 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;
#ifdef GC_FREE_SEGMENTS
if (n == seg_size)
{
+ register long j;
+
scm_heap_size -= seg_size;
free ((char *) scm_heap_table[i].bounds[0]);
scm_heap_table[i].bounds[0] = 0;
#endif
scm_gc_cells_collected += n;
- n = 0;
}
/* Scan weak vectors. */
{
{
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)
}
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;
/* {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.
*/
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);
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;
* 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);
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;
else
scm_wta (SCM_INUM0, "already free", "");
}
-\f
+/* 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;
+ }
+ }
+}
+
+
+\f
/* {Heap Segments}
*
* 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.
/* 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.
#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;
{}
-#ifdef __STDC__
SCM
scm_return_first (SCM elt, ...)
-#else
-SCM
-scm_return_first (elt, va_alist)
- SCM elt;
- va_dcl
-#endif
{
return elt;
}
}
+/* 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;
+}
+
+
\f
int
-scm_init_storage (init_heap_size)
- long init_heap_size;
+scm_init_storage (scm_sizet init_heap_size)
{
scm_sizet j;
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. */
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));
HCoop / bpt / guile.git / blobdiff