-/* 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"
/* 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
SCM_THREAD_CRITICAL_SECTION_START;
#endif
+ /* fprintf (stderr, "gc: %s\n", what); */
+
scm_gc_start (what);
if (!scm_stack_base || scm_block_gc)
{
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))
{
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
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_STACKITEM) + -1 + 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);
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);
}
}
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
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;
+ scm_sizet len;
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);
* 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,
+ 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);
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;
}
even if all other references are dropped, until someone applies
scm_unprotect_object to it. This function returns OBJ.
- Note that calls to scm_protect_object do not nest. You can call
- scm_protect_object any number of times on a given object, and the
- next call to scm_unprotect_object will unprotect it completely.
-
- Basically, 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 remove its
- argument from the list. */
+ 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;
{
- /* This function really should use address hashing tables, but I
- don't know how to use them yet. For now we just use a list. */
scm_protects = scm_cons (obj, scm_protects);
return obj;
/* Remove any protection for OBJ established by a prior call to
- scm_protect_obj. This function returns OBJ.
+ scm_protect_object. This function returns OBJ.
- See scm_protect_obj for more information. */
+ See scm_protect_object for more information. */
SCM
scm_unprotect_object (obj)
SCM obj;
{
- scm_protects = scm_delq_x (obj, scm_protects);
+ 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_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;
HCoop / bpt / guile.git / blobdiff