-/* 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 "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 <malloc.h>
#include <unistd.h>
#endif
+#ifdef __STDC__
+#include <stdarg.h>
+#define var_start(x, y) va_start(x, y)
+#else
+#include <varargs.h>
+#define var_start(x, y) va_start(x)
+#endif
+
\f
/* {heap tuning parameters}
*
*
* 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
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 *));
+
+
+\f
+/* 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 */
\f
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;
+#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)
{
++scm_gc_heap_lock;
scm_n_weak = 0;
+ scm_guardian_gc_init ();
+
/* unprotect any struct types with no instances */
#if 0
{
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
}
}
+#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
/* 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
#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.
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
}
\f
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);
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;
}
}
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:
#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_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:
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;
#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
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;
}
{
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;
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;
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;
/* 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:
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);
#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. */
{
{
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;
*fixup = SCM_CDR (alist);
}
else
- fixup = &SCM_CDR (alist);
+ fixup = SCM_CDRLOC (alist);
alist = SCM_CDR (alist);
}
}
/* {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 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;
}
/* 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);
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;
}
}
+/* 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_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));
HCoop / bpt / guile.git / blobdiff