-/* Copyright (C) 1995,1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000 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
* 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. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
\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"
+#include "validate.h"
#include "gc.h"
#ifdef HAVE_MALLOC_H
* work around a oscillation that caused almost constant GC.]
*/
-#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
-#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
+#define SCM_INIT_HEAP_SIZE (40000L * sizeof (scm_cell))
+#define SCM_MIN_HEAP_SEG_SIZE (2048L * sizeof (scm_cell))
#ifdef _QC
# define SCM_HEAP_SEG_SIZE 32768L
#else
# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
# endif
#endif
-#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
+#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)
+#define SCM_GC_TRIGGER 10000
+#define SCM_GC_TRIGGER2 10000
+
/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
bounds for allocated storage */
\f
-/* scm_freelist
- * is the head of freelist of cons pairs.
+/* scm_freelists
*/
+
+#ifdef GUILE_NEW_GC_SCHEME
SCM scm_freelist = SCM_EOL;
+scm_freelist_t scm_master_freelist = {
+ SCM_EOL, 0, SCM_EOL, SCM_EOL, 0, 0, 1, 0, 0
+};
+SCM scm_freelist2 = SCM_EOL;
+scm_freelist_t scm_master_freelist2 = {
+ SCM_EOL, 0, SCM_EOL, SCM_EOL, 0, 0, 2, 0, 0
+};
+#else
+scm_freelist_t scm_freelist = { SCM_EOL, 1, 0, 0 };
+scm_freelist_t scm_freelist2 = { SCM_EOL, 2, 0, 0 };
+#endif
/* 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
/* 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)
+#define MIN_GC_YIELD(freelist) (freelist->heap_size / 4)
/* During collection, this accumulates objects holding
* weak references.
*/
-SCM *scm_weak_vectors;
-int scm_weak_size;
-int scm_n_weak;
+SCM scm_weak_vectors;
/* GC Statistics Keeping
*/
unsigned long scm_cells_allocated = 0;
-unsigned long scm_mallocated = 0;
-unsigned long scm_gc_cells_collected;
+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;
/* address of the head-of-freelist pointer for this segment's cells.
All segments usually point to the same one, scm_freelist. */
- SCM *freelistp;
+ scm_freelist_t *freelistp;
/* number of SCM words per object in this segment */
- int ncells;
+ int span;
/* If SEG_DATA->valid is non-zero, the conservative marking
functions will apply SEG_DATA->valid to the purported pointer and
-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 *));
+static void scm_mark_weak_vector_spines (void);
+static scm_sizet init_heap_seg (SCM_CELLPTR, scm_sizet, scm_freelist_t *);
+static void alloc_some_heap (scm_freelist_t *);
\f
/* Debugging functions. */
-#ifdef DEBUG_FREELIST
+#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
/* Return the number of the heap segment containing CELL. */
static int
&& 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);
+ SCM_UNPACK (cell));
abort ();
}
-SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list);
-SCM
-scm_map_free_list ()
+#ifdef GUILE_NEW_GC_SCHEME
+static void
+map_free_list (scm_freelist_t *master, SCM freelist)
{
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))
+ for (f = 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 %d-cells in segment %d\n",
+ count, master->span, last_seg);
+ last_seg = this_seg;
+ count = 0;
+ }
+ count++;
+ }
+ if (last_seg != -1)
+ fprintf (stderr, " %5d %d-cells in segment %d\n",
+ count, master->span, last_seg);
+}
+#else
+static void
+map_free_list (scm_freelist_t *freelistp)
+{
+ int last_seg = -1, count = 0;
+ SCM f;
+
+ for (f = freelistp->cells; 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);
+ fprintf (stderr, " %5d %d-cells in segment %d\n",
+ count, freelistp->span, last_seg);
last_seg = this_seg;
count = 0;
}
count++;
}
if (last_seg != -1)
- fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
+ fprintf (stderr, " %5d %d-cells in segment %d\n",
+ count, freelistp->span, last_seg);
+}
+#endif
+SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
+ (),
+ "Print debugging information about the free-list.\n"
+ "`map-free-list' is only included in --enable-guile-debug builds of Guile.")
+#define FUNC_NAME s_scm_map_free_list
+{
+ fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
+#ifdef GUILE_NEW_GC_SCHEME
+ map_free_list (&scm_master_freelist, scm_freelist);
+ map_free_list (&scm_master_freelist2, scm_freelist2);
+#else
+ map_free_list (&scm_freelist);
+ map_free_list (&scm_freelist2);
+#endif
fflush (stderr);
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
+static int
+free_list_length (char *title, int i, SCM freelist)
+{
+ SCM ls;
+ int n = 0;
+ for (ls = freelist; SCM_NNULLP (ls); ls = SCM_CDR (ls))
+ if (SCM_UNPACK_CAR (ls) == scm_tc_free_cell)
+ ++n;
+ else
+ {
+ fprintf (stderr, "bad cell in %s at position %d\n", title, n);
+ abort ();
+ }
+ if (i >= 0)
+ fprintf (stderr, "%s %d\t%d\n", title, i, n);
+ else
+ fprintf (stderr, "%s\t%d\n", title, n);
+ return n;
+}
+
+static void
+free_list_lengths (char *title, scm_freelist_t *master, SCM freelist)
+{
+ SCM clusters;
+ int i = 0, n = 0;
+ fprintf (stderr, "%s\n\n", title);
+ n += free_list_length ("free list", -1, freelist);
+ for (clusters = master->clusters;
+ SCM_NNULLP (clusters);
+ clusters = SCM_CDR (clusters))
+ n += free_list_length ("cluster", i++, SCM_CAR (clusters));
+ fprintf (stderr, "\ntotal %d cells\n\n", n);
+}
+
+SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0,
+ (),
+ "Print debugging information about the free-list.\n"
+ "`free-list-length' is only included in --enable-guile-debug builds of Guile.")
+#define FUNC_NAME s_scm_free_list_length
+{
+#ifdef GUILE_NEW_GC_SCHEME
+ free_list_lengths ("1-words", &scm_master_freelist, scm_freelist);
+ free_list_lengths ("2-words", &scm_master_freelist2, scm_freelist2);
+#endif
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#endif
+
+#ifdef GUILE_DEBUG_FREELIST
/* Number of calls to SCM_NEWCELL since startup. */
static unsigned long scm_newcell_count;
+static unsigned long scm_newcell2_count;
/* Search freelist for anything that isn't marked as a free cell.
Abort if we find something. */
+#ifdef GUILE_NEW_GC_SCHEME
static void
-scm_check_freelist ()
+scm_check_freelist (SCM freelist)
{
SCM f;
int i = 0;
- for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
+ for (f = 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",
abort ();
}
}
+#else
+static void
+scm_check_freelist (scm_freelist_t *freelistp)
+{
+ SCM f;
+ int i = 0;
+
+ for (f = freelistp->cells; 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 ();
+ }
+}
+#endif
static int scm_debug_check_freelist = 0;
-void
-scm_debug_newcell (SCM *into)
+
+SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
+ (SCM flag),
+ "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
+ "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
+ "compile-time flag was selected.\n")
+#define FUNC_NAME s_scm_gc_set_debug_check_freelist_x
+{
+ SCM_VALIDATE_BOOL_COPY (1, flag, scm_debug_check_freelist);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+#ifdef GUILE_NEW_GC_SCHEME
+
+SCM
+scm_debug_newcell (void)
{
+ SCM new;
+
scm_newcell_count++;
if (scm_debug_check_freelist)
- scm_check_freelist ();
+ {
+ scm_check_freelist (scm_freelist);
+ scm_gc();
+ }
/* 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 (&scm_master_freelist, &scm_freelist);
else
{
- *into = scm_freelist;
+ new = scm_freelist;
scm_freelist = SCM_CDR (scm_freelist);
+ SCM_SETCAR (new, scm_tc16_allocated);
+ }
+
+ return new;
+}
+
+SCM
+scm_debug_newcell2 (void)
+{
+ SCM new;
+
+ scm_newcell2_count++;
+ if (scm_debug_check_freelist)
+ {
+ scm_check_freelist (scm_freelist2);
+ scm_gc ();
+ }
+
+ /* The rest of this is supposed to be identical to the SCM_NEWCELL
+ macro. */
+ if (SCM_IMP (scm_freelist2))
+ new = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
+ else
+ {
+ new = scm_freelist2;
+ scm_freelist2 = SCM_CDR (scm_freelist2);
+ SCM_SETCAR (new, scm_tc16_allocated);
+ }
+
+ return new;
+}
+
+#else /* GUILE_NEW_GC_SCHEME */
+
+SCM
+scm_debug_newcell (void)
+{
+ SCM new;
+
+ scm_newcell_count++;
+ if (scm_debug_check_freelist)
+ {
+ scm_check_freelist (&scm_freelist);
+ scm_gc();
+ }
+
+ /* The rest of this is supposed to be identical to the SCM_NEWCELL
+ macro. */
+ if (SCM_IMP (scm_freelist.cells))
+ new = scm_gc_for_newcell (&scm_freelist);
+ else
+ {
+ new = scm_freelist.cells;
+ scm_freelist.cells = SCM_CDR (scm_freelist.cells);
+ SCM_SETCAR (new, scm_tc16_allocated);
++scm_cells_allocated;
}
+
+ return new;
}
-#endif /* DEBUG_FREELIST */
+SCM
+scm_debug_newcell2 (void)
+{
+ SCM new;
+
+ scm_newcell2_count++;
+ if (scm_debug_check_freelist) {
+ scm_check_freelist (&scm_freelist2);
+ scm_gc();
+ }
+
+ /* The rest of this is supposed to be identical to the SCM_NEWCELL2
+ macro. */
+ if (SCM_IMP (scm_freelist2.cells))
+ new = scm_gc_for_newcell (&scm_freelist2);
+ else
+ {
+ new = scm_freelist2.cells;
+ scm_freelist2.cells = SCM_CDR (scm_freelist2.cells);
+ SCM_SETCAR (new, scm_tc16_allocated);
+ scm_cells_allocated += 2;
+ }
+
+ return new;
+}
+
+#endif /* GUILE_NEW_GC_SCHEME */
+#endif /* GUILE_DEBUG_FREELIST */
\f
/* {Scheme Interface to GC}
*/
-SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
-SCM
-scm_gc_stats ()
+SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
+ (),
+ "Returns an association list of statistics about Guile's current use of storage. ")
+#define FUNC_NAME s_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;
+ long int local_scm_mtrigger;
+ long int local_scm_mallocated;
+ long int local_scm_heap_size;
+ long int local_scm_cells_allocated;
+ long int local_scm_gc_time_taken;
SCM answer;
SCM_DEFER_INTS;
goto retry;
scm_block_gc = 0;
+ /// ? ?? ?
local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated;
- local_scm_heap_size = scm_heap_size;
+#ifdef GUILE_NEW_GC_SCHEME
+ local_scm_heap_size = scm_master_freelist.heap_size; /*fixme*/
+#else
+ local_scm_heap_size = scm_freelist.heap_size; /*fixme*/
+#endif
local_scm_cells_allocated = scm_cells_allocated;
local_scm_gc_time_taken = scm_gc_time_taken;
SCM_ALLOW_INTS;
return answer;
}
+#undef FUNC_NAME
void
-scm_gc_start (what)
- char *what;
+scm_gc_start (const char *what)
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
- scm_gc_cells_collected = 0;
+ /* scm_gc_cells_collected = 0; */
scm_gc_malloc_collected = 0;
scm_gc_ports_collected = 0;
}
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_gc_time_taken += scm_gc_rt;
scm_system_async_mark (scm_gc_async);
}
-SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr);
-SCM
-scm_object_addr (obj)
- SCM obj;
+SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
+ (SCM obj),
+ "Return an integer that for the lifetime of @var{obj} is uniquely\n"
+ "returned by this function for @var{obj}")
+#define FUNC_NAME s_scm_object_address
{
- return scm_ulong2num ((unsigned long)obj);
+ return scm_ulong2num ((unsigned long) obj);
}
+#undef FUNC_NAME
-SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
-SCM
-scm_gc ()
+SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
+ (),
+ "Scans all of SCM objects and reclaims for further use those that are\n"
+ "no longer accessible.")
+#define FUNC_NAME s_scm_gc
{
SCM_DEFER_INTS;
scm_igc ("call");
SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
\f
/* {C Interface For When GC is Triggered}
*/
+#ifdef GUILE_NEW_GC_SCHEME
+
+/* When we get POSIX threads support, the master will be global and
+ common while the freelist will be individual for each thread. */
+
+SCM
+scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist)
+{
+ SCM cell;
+ ++scm_ints_disabled;
+ if (master->triggeredp)
+ scm_igc ("cells");
+ else if (SCM_NULLP (master->clusters))
+ alloc_some_heap (master);
+ else if (SCM_NULLP (SCM_CDR (master->clusters)))
+ /* we are satisfied; GC instead of alloc next time around */
+ master->triggeredp = 1;
+ --scm_ints_disabled;
+ cell = SCM_CAR (master->clusters);
+ master->clusters = SCM_CDR (master->clusters);
+ *freelist = SCM_CDR (cell);
+ SCM_SETCAR (cell, scm_tc16_allocated);
+ return cell;
+}
+
+#else /* GUILE_NEW_GC_SCHEME */
+
void
-scm_gc_for_alloc (ncells, freelistp)
- int ncells;
- SCM * freelistp;
+scm_gc_for_alloc (scm_freelist_t *freelistp)
{
SCM_REDEFER_INTS;
scm_igc ("cells");
- if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp))
- {
- alloc_some_heap (ncells, freelistp);
- }
+#ifdef GUILE_DEBUG_FREELIST
+ fprintf (stderr, "Collected: %d, min_yield: %d\n",
+ freelistp->collected, MIN_GC_YIELD (freelistp));
+#endif
+ if ((freelistp->collected < MIN_GC_YIELD (freelistp))
+ || SCM_IMP (freelistp->cells))
+ alloc_some_heap (freelistp);
SCM_REALLOW_INTS;
}
SCM
-scm_gc_for_newcell ()
+scm_gc_for_newcell (scm_freelist_t *freelistp)
{
SCM fl;
- scm_gc_for_alloc (1, &scm_freelist);
- fl = scm_freelist;
- scm_freelist = SCM_CDR (fl);
+ scm_gc_for_alloc (freelistp);
+ fl = freelistp->cells;
+ freelistp->cells = SCM_CDR (fl);
+ SCM_SETCAR (fl, scm_tc16_allocated);
return fl;
}
+#endif /* GUILE_NEW_GC_SCHEME */
+
void
-scm_igc (what)
- char *what;
+scm_igc (const char *what)
{
int j;
SCM_THREAD_CRITICAL_SECTION_START;
#endif
- // fprintf (stderr, "gc: %s\n", what);
+ /* fprintf (stderr, "gc: %s\n", what); */
scm_gc_start (what);
+
if (!scm_stack_base || scm_block_gc)
{
scm_gc_end ();
return;
}
+ if (scm_mallocated < 0)
+ /* The byte count of allocated objects has underflowed. This is
+ probably because you forgot to report the sizes of objects you
+ have allocated, by calling scm_done_malloc or some such. When
+ the GC freed them, it subtracted their size from
+ scm_mallocated, which underflowed. */
+ abort ();
+
+ if (scm_gc_heap_lock)
+ /* We've invoked the collector while a GC is already in progress.
+ That should never happen. */
+ abort ();
+
++scm_gc_heap_lock;
- scm_n_weak = 0;
+
+ scm_weak_vectors = SCM_EOL;
+
+ scm_guardian_gc_init ();
/* unprotect any struct types with no instances */
#if 0
#else /* USE_THREADS */
/* Mark every thread's stack and registers */
- scm_threads_mark_stacks();
+ scm_threads_mark_stacks ();
#endif /* USE_THREADS */
while (j--)
scm_gc_mark (scm_sys_protects[j]);
+ /* FIXME: we should have a means to register C functions to be run
+ * in different phases of GC
+ */
+ scm_mark_subr_table ();
+
#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;
/* Mark an object precisely.
*/
void
-scm_gc_mark (p)
- SCM p;
+scm_gc_mark (SCM p)
{
register long i;
register SCM ptr;
SCM_SETGCMARK (ptr);
ptr = SCM_GCCDR (ptr);
goto gc_mark_loop;
+ case scm_tc7_pws:
+ if (SCM_GCMARKP (ptr))
+ break;
+ SCM_SETGCMARK (ptr);
+ scm_gc_mark (SCM_CELL_WORD (ptr, 2));
+ ptr = SCM_GCCDR (ptr);
+ goto gc_mark_loop;
case scm_tcs_cons_gloc:
if (SCM_GCMARKP (ptr))
break;
{
SCM vcell;
vcell = SCM_CAR (ptr) - 1L;
- switch (SCM_CDR (vcell))
+ switch (SCM_UNPACK (SCM_CDR (vcell)))
{
default:
scm_gc_mark (vcell);
that it removes the mark */
mem = (SCM *)SCM_GCCDR (ptr);
+ if (SCM_UNPACK (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
+ {
+ scm_gc_mark (mem[scm_struct_i_procedure]);
+ scm_gc_mark (mem[scm_struct_i_setter]);
+ }
if (len)
{
for (x = 0; x < len - 2; x += 2, ++mem)
scm_gc_mark (*mem);
if (fields_desc[x] == 'p')
{
+ int j;
if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = *mem; x; --x)
+ for (j = (long int) *mem; x; --x)
scm_gc_mark (*++mem);
else
scm_gc_mark (*mem);
(ptr) break;
SCM_SETGC8MARK (ptr);
if (SCM_VELTS (ptr))
- scm_mark_locations (SCM_VELTS (ptr),
+ scm_mark_locations (SCM_VELTS_AS_STACKITEMS (ptr),
(scm_sizet)
(SCM_LENGTH (ptr) +
(sizeof (SCM_STACKITEM) + -1 +
sizeof (scm_contregs)) /
sizeof (SCM_STACKITEM)));
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_ivect:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
-
+#endif
case scm_tc7_string:
SCM_SETGC8MARK (ptr);
break;
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_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_WVECT_GC_CHAIN (ptr) = scm_weak_vectors;
+ scm_weak_vectors = ptr;
SCM_SETGC8MARK (ptr);
if (SCM_IS_WHVEC_ANY (ptr))
{
{
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)
+
+ /* mark everything on the alist except the keys or
+ * values, according to weak_values and weak_keys. */
+ while ( SCM_CONSP (alist)
&& !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
&& SCM_CONSP (SCM_CAR (alist)))
{
SCM kvpair;
SCM_SETGC8MARK (ptr);
break;
case scm_tcs_subrs:
- ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8));
- goto gc_mark_loop;
+ break;
case scm_tc7_port:
i = SCM_PTOBNUM (ptr);
if (!(i < scm_numptob))
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);
+ case scm_tc16_allocated:
+ case scm_tc16_big:
+ case scm_tc16_real:
+ case scm_tc16_complex:
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:
*/
void
-scm_mark_locations (x, n)
- SCM_STACKITEM x[];
- scm_sizet n;
+scm_mark_locations (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])
+ if (SCM_CELLP (*(SCM **) (& x[m])))
{
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
i = 0;
int
-scm_cellp (value)
- SCM value;
+scm_cellp (SCM value)
{
register int i, j;
register SCM_CELLPTR ptr;
- if SCM_CELLP (*(SCM **) & value)
+ if SCM_CELLP (*(SCM **) (& value))
{
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
i = 0;
static void
scm_mark_weak_vector_spines ()
{
- int i;
+ SCM w;
- for (i = 0; i < scm_n_weak; ++i)
+ for (w = scm_weak_vectors; w != SCM_EOL; w = SCM_WVECT_GC_CHAIN (w))
{
- if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
+ if (SCM_IS_WHVEC_ANY (w))
{
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]);
+ obj = w;
+ ptr = SCM_VELTS (w);
+ n = SCM_LENGTH (w);
for (j = 0; j < n; ++j)
{
SCM alist;
alist = ptr[j];
- while ( SCM_NIMP (alist)
- && SCM_CONSP (alist)
+ while ( SCM_CONSP (alist)
&& !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
&& SCM_CONSP (SCM_CAR (alist)))
{
SCM_SETGCMARK (alist);
#define scmptr (SCM)ptr
#endif
register SCM nfreelist;
- register SCM *hp_freelist;
- register long n;
+ register scm_freelist_t *hp_freelist;
register long m;
- register scm_sizet j;
register int span;
- scm_sizet i;
+ long i;
scm_sizet seg_size;
- n = 0;
m = 0;
+#ifdef GUILE_NEW_GC_SCHEME
/* 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;
-
+ {
+ scm_heap_table[i].freelistp->cells = SCM_EOL;
+ scm_heap_table[i].freelistp->n_objects
+ = scm_heap_table[i].freelistp->gc_trigger;
+ scm_heap_table[i].freelistp->clusters = SCM_EOL;
+ scm_heap_table[i].freelistp->clustertail
+ = &scm_heap_table[i].freelistp->clusters;
+ scm_heap_table[i].freelistp->triggeredp = 0;
+ }
+#else
+ /* 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->cells = SCM_EOL;
+#endif
+
for (i = 0; i < scm_n_heap_segs; i++)
{
+ register scm_sizet n = 0;
+ register scm_sizet j;
+#ifdef GUILE_NEW_GC_SCHEME
+ register int n_objects;
+#endif
+
/* 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
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 = *hp_freelist;
+ nfreelist = hp_freelist->cells;
+#ifdef GUILE_NEW_GC_SCHEME
+ n_objects = hp_freelist->n_objects;
+#endif
+ span = scm_heap_table[i].span;
+ hp_freelist->collected = 0;
- 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;
for (j = seg_size + span; j -= span; ptr += span)
SCM vcell;
vcell = SCM_CAR (scmptr) - 1L;
- if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
+ if ((SCM_CDR (vcell) == 0) || (SCM_UNPACK (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]);
+ scm_struct_free_t free
+ = (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free];
+ m += free ((SCM *) vcell, (SCM *) SCM_GCCDR (scmptr));
}
}
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;
}
else
{
- m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM);
- scm_must_free ((char *)(SCM_VELTS (scmptr) - 1));
+ m += (2 + SCM_LENGTH (scmptr)) * sizeof (SCM);
+ scm_must_free ((char *)(SCM_VELTS (scmptr) - 2));
break;
}
scm_must_free (SCM_CHARS (scmptr));
/* SCM_SETCHARS(scmptr, 0);*/
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
goto freechars;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
goto freechars;
+#endif
case scm_tc7_substring:
if (SCM_GC8MARKP (scmptr))
goto c8mrkcontinue;
if (!(k < scm_numptob))
goto sweeperr;
/* Keep "revealed" ports alive. */
- if (scm_revealed_count(scmptr) > 0)
+ 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));
+ m += (scm_ptobs[k].free) (scmptr);
SCM_SETSTREAM (scmptr, 0);
scm_remove_from_port_table (scmptr);
scm_gc_ports_collected++;
switch SCM_GCTYP16 (scmptr)
{
case scm_tc_free_cell:
+ case scm_tc16_real:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
break;
#ifdef SCM_BIGDIG
- case scm_tcs_bignums:
+ case scm_tc16_big:
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:
+ case scm_tc16_complex:
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;
+ m += 2 * sizeof (double);
+ goto freechars;
default:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
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
- /* 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;
-
+#ifndef GUILE_NEW_GC_SCHEME
+ n += span;
+#else
+ if (--n_objects < 0)
+ {
+ SCM_SETCAR (scmptr, nfreelist);
+ *hp_freelist->clustertail = scmptr;
+ hp_freelist->clustertail = SCM_CDRLOC (scmptr);
+
+ nfreelist = SCM_EOL;
+ n += span * (hp_freelist->gc_trigger - n_objects);
+ n_objects = hp_freelist->gc_trigger;
+ }
+ else
+#endif
+ {
+ /* 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_tc_free_cell);
+ SCM_SETCDR (scmptr, nfreelist);
+ nfreelist = scmptr;
+ }
+
continue;
c8mrkcontinue:
SCM_CLRGC8MARK (scmptr);
#ifdef GC_FREE_SEGMENTS
if (n == seg_size)
{
- scm_heap_size -= seg_size;
- n = 0;
+ register long j;
+
+ hp_freelist->heap_size -= seg_size;
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++)
}
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;
+ {
+ /* Update the real freelist pointer to point to the head of
+ the list of free cells we've built for this segment. */
+ hp_freelist->cells = nfreelist;
+#ifdef GUILE_NEW_GC_SCHEME
+ hp_freelist->n_objects = n_objects;
+#endif
+ }
-#ifdef DEBUG_FREELIST
- scm_check_freelist ();
- scm_map_free_list ();
+#ifdef GUILE_NEW_GC_SCHEME
+ j = span * (hp_freelist->gc_trigger - n_objects);
+ /* sum up---if this is last turn for this freelist */
+ hp_freelist->collected += n + j;
+ n -= j; /* compensate for the sum up */
+#else
+ hp_freelist->collected += n;
#endif
+ scm_cells_allocated += hp_freelist->heap_size - hp_freelist->collected;
- scm_gc_cells_collected += n;
- n = 0;
+#ifdef GUILE_DEBUG_FREELIST
+#ifdef GUILE_NEW_GC_SCHEME
+ scm_check_freelist (hp_freelist == &scm_master_freelist
+ ? scm_freelist
+ : scm_freelist2);
+#else
+ scm_check_freelist (hp_freelist);
+#endif
+ scm_map_free_list ();
+#endif
}
+
+#ifdef GUILE_NEW_GC_SCHEME
+ for (i = 0; i < scm_n_heap_segs; i++)
+ if (scm_heap_table[i].freelistp->clustertail != NULL)
+ {
+ scm_freelist_t *hp_freelist = scm_heap_table[i].freelistp;
+ if (hp_freelist->gc_trigger - hp_freelist->n_objects > 1)
+ {
+ SCM c = hp_freelist->cells;
+ hp_freelist->n_objects = hp_freelist->gc_trigger;
+ SCM_SETCAR (c, SCM_CDR (c));
+ SCM_SETCDR (c, SCM_EOL);
+ *hp_freelist->clustertail = c;
+ }
+ else
+ *hp_freelist->clustertail = SCM_EOL;
+ hp_freelist->clustertail = NULL;
+ }
+
+ /* When we move to POSIX threads private freelists should probably
+ be GC-protected instead. */
+ scm_freelist = SCM_EOL;
+ scm_freelist2 = SCM_EOL;
+#endif
+
/* Scan weak vectors. */
{
- SCM *ptr;
- for (i = 0; i < scm_n_weak; ++i)
+ SCM *ptr, w;
+ for (w = scm_weak_vectors; w != SCM_EOL; w = SCM_WVECT_GC_CHAIN (w))
{
- if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
+ if (!SCM_IS_WHVEC_ANY (w))
{
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
+ register long j, n;
+
+ ptr = SCM_VELTS (w);
+ n = SCM_LENGTH (w);
for (j = 0; j < n; ++j)
- if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j]))
+ if (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]);
+ SCM obj = w;
+ register long n = SCM_LENGTH (w);
+ register long j;
+
+ ptr = SCM_VELTS (w);
+
for (j = 0; j < n; ++j)
{
SCM * fixup;
fixup = ptr + j;
alist = *fixup;
- while (SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && SCM_NIMP (SCM_CAR (alist))
+ while ( SCM_CONSP (alist)
&& SCM_CONSP (SCM_CAR (alist)))
{
SCM key;
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)))
+ if ( (weak_keys && SCM_FREEP (key))
+ || (weak_values && SCM_FREEP (value)))
{
*fixup = SCM_CDR (alist);
}
}
}
}
- scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
scm_mallocated -= m;
scm_gc_malloc_collected = m;
}
*
* The limit scm_mtrigger may be raised by this allocation.
*/
-char *
-scm_must_malloc (len, what)
- long len;
- char *what;
+void *
+scm_must_malloc (scm_sizet size, const 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))
+ void *ptr;
+ unsigned long nm = scm_mallocated + size;
+
+ if (nm <= scm_mtrigger)
{
- SCM_SYSCALL (ptr = (char *) malloc (size));
+ SCM_SYSCALL (ptr = malloc (size));
if (NULL != ptr)
{
scm_mallocated = nm;
}
scm_igc (what);
+
nm = scm_mallocated + size;
- SCM_SYSCALL (ptr = (char *) malloc (size));
+ SCM_SYSCALL (ptr = malloc (size));
if (NULL != ptr)
{
scm_mallocated = nm;
}
return ptr;
}
- goto malerr;
+
+ scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what);
+ return 0; /* never reached */
}
/* 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;
+void *
+scm_must_realloc (void *where,
+ scm_sizet old_size,
+ scm_sizet size,
+ const 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))
+ void *ptr;
+ scm_sizet nm = scm_mallocated + size - old_size;
+
+ if (nm <= scm_mtrigger)
{
- SCM_SYSCALL (ptr = (char *) realloc (where, size));
+ SCM_SYSCALL (ptr = 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));
+
+ nm = scm_mallocated + size - old_size;
+ SCM_SYSCALL (ptr = realloc (where, size));
if (NULL != ptr)
{
scm_mallocated = nm;
}
return ptr;
}
- goto ralerr;
+
+ scm_wta (SCM_MAKINUM (size), (char *) SCM_NALLOC, what);
+ return 0; /* never reached */
}
void
-scm_must_free (obj)
- char *obj;
+scm_must_free (void *obj)
{
if (obj)
free (obj);
* value. */
void
-scm_done_malloc (size)
- long size;
+scm_done_malloc (long size)
{
scm_mallocated += size;
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.
*
static scm_sizet
-init_heap_seg (seg_org, size, ncells, freelistp)
- SCM_CELLPTR seg_org;
- scm_sizet size;
- int ncells;
- SCM *freelistp;
+init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelistp)
{
register SCM_CELLPTR ptr;
#ifdef SCM_POINTERS_MUNGED
#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_cells;
+ int span = freelistp->span;
if (seg_org == NULL)
return 0;
ptr = seg_org;
+ size = (size / sizeof (scm_cell) / span) * span * sizeof (scm_cell);
+
/* Compute the ceiling on valid object pointers w/in this segment.
*/
seg_end = CELL_DN ((char *) ptr + size);
++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].span = span;
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;
ptr = CELL_UP (ptr);
- n_new_objects = seg_end - ptr;
+ /*n_new_cells*/
+ n_new_cells = seg_end - ptr;
+
+#ifdef GUILE_NEW_GC_SCHEME
+
+ freelistp->heap_size += n_new_cells;
+
+ /* Partition objects in this segment into clusters
+ */
+ {
+ SCM clusters;
+ SCM *clusterp = &clusters;
+ int trigger = span * freelistp->gc_trigger;
+ int n, c = 0;
+
+ while (n_new_cells > span)
+ {
+ if (n_new_cells > trigger)
+ n = span + trigger;
+ else
+ n = n_new_cells;
+ n_new_cells -= n;
+ n -= span;
+ c += span;
+
+ *clusterp = PTR2SCM (ptr);
+ SCM_SETCAR (*clusterp, PTR2SCM (ptr + span));
+ clusterp = SCM_CDRLOC (*clusterp);
+
+ ptr += span;
+ seg_end = ptr + n;
+ while (ptr < seg_end)
+ {
+#ifdef SCM_POINTERS_MUNGED
+ scmptr = PTR2SCM (ptr);
+#endif
+ SCM_SETCAR (scmptr, scm_tc_free_cell);
+ SCM_SETCDR (scmptr, PTR2SCM (ptr + span));
+ ptr += span;
+ }
+ SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL);
+ }
+
+ /* Correction for cluster cells + spill */
+ freelistp->heap_size -= c + n_new_cells;
+
+ /* Patch up the last cluster pointer in the segment
+ * to join it to the input freelist.
+ */
+ *clusterp = freelistp->clusters;
+ freelistp->clusters = clusters;
+ }
+
+#else /* GUILE_NEW_GC_SCHEME */
/* Prepend objects in this segment to the freelist.
*/
scmptr = PTR2SCM (ptr);
#endif
SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
- SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
- ptr += ncells;
+ SCM_SETCDR (scmptr, PTR2SCM (ptr + span));
+ ptr += span;
}
- ptr -= ncells;
+ ptr -= span;
/* 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_SETCDR (PTR2SCM (ptr), freelistp->cells);
+ freelistp->cells = PTR2SCM (CELL_UP (seg_org));
- scm_heap_size += (ncells * n_new_objects);
+ freelistp->heap_size += n_new_cells;
+
+#endif /* GUILE_NEW_GC_SCHEME */
+
return size;
#ifdef scmptr
#undef scmptr
static void
-alloc_some_heap (ncells, freelistp)
- int ncells;
- SCM * freelistp;
+alloc_some_heap (scm_freelist_t *freelistp)
{
struct scm_heap_seg_data * tmptable;
SCM_CELLPTR ptr;
*/
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 = (scm_sizet) SCM_EXPHEAP (freelistp->heap_size * sizeof (scm_cell));
+ if ((scm_sizet) SCM_EXPHEAP (freelistp->heap_size * sizeof (scm_cell))
+ != len)
len = 0;
}
else
{
scm_sizet smallest;
- smallest = (ncells * sizeof (scm_cell));
+ smallest = (freelistp->span * sizeof (scm_cell));
if (len < smallest)
- len = (ncells * sizeof (scm_cell));
+ len = (freelistp->span * sizeof (scm_cell));
/* Allocate with decaying ambition. */
while ((len >= SCM_MIN_HEAP_SEG_SIZE)
SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
if (ptr)
{
- init_heap_seg (ptr, len, ncells, freelistp);
+ init_heap_seg (ptr, len, freelistp);
return;
}
len /= 2;
-SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
-SCM
-scm_unhash_name (name)
- SCM name;
+SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
+ (SCM name),
+ "")
+#define FUNC_NAME s_scm_unhash_name
{
int x;
int bound;
- SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
+ SCM_VALIDATE_SYMBOL (1,name);
SCM_DEFER_INTS;
bound = scm_n_heap_segs;
for (x = 0; x < bound; ++x)
--incar;
if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
&& (SCM_CDR (incar) != 0)
- && (SCM_CDR (incar) != 1))
+ && (SCM_UNPACK (SCM_CDR (incar)) != 1))
{
p->car = name;
}
SCM_ALLOW_INTS;
return name;
}
+#undef FUNC_NAME
\f
void
-scm_remember (ptr)
- SCM * ptr;
-{}
-
-
-#ifdef __STDC__
+scm_remember (SCM *ptr)
+{ /* empty */ }
+
+
+/*
+ These crazy functions prevent garbage collection
+ of arguments after the first argument by
+ ensuring they remain live throughout the
+ function because they are used in the last
+ line of the code block.
+ It'd be better to have a nice compiler hint to
+ aid the conservative stack-scanning GC. --03/09/00 gjb */
SCM
scm_return_first (SCM elt, ...)
-#else
-SCM
-scm_return_first (elt, va_alist)
- SCM elt;
- va_dcl
-#endif
{
return elt;
}
+int
+scm_return_first_int (int i, ...)
+{
+ return i;
+}
+
SCM
-scm_permanent_object (obj)
- SCM obj;
+scm_permanent_object (SCM obj)
{
SCM_REDEFER_INTS;
scm_permobjs = scm_cons (obj, scm_permobjs);
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 OBJ, there is a
+ counter which scm_protect_object(OBJ) increments and
+ scm_unprotect_object(OBJ) 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_protect_object (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_unprotect_object (SCM obj)
{
- scm_protects = scm_delq_x (obj, scm_protects);
+ SCM *tail_ptr = &scm_protects;
+
+ while (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 terminating;
+
+/* called on process termination. */
+#ifdef HAVE_ATEXIT
+static void
+cleanup (void)
+#else
+#ifdef HAVE_ON_EXIT
+extern int on_exit (void (*procp) (), int arg);
+
+static void
+cleanup (int status, void *arg)
+#else
+#error Dont know how to setup a cleanup handler on your system.
+#endif
+#endif
+{
+ terminating = 1;
+ scm_flush_all_ports ();
+}
+
+\f
+static int
+make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelistp)
+{
+ if (0L == init_heap_size)
+ init_heap_size = SCM_INIT_HEAP_SIZE;
+ if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
+ init_heap_size,
+ freelistp))
+ {
+ init_heap_size = SCM_HEAP_SEG_SIZE;
+ if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
+ init_heap_size,
+ freelistp))
+ return 1;
+ }
+ else
+ scm_expmem = 1;
+
+ return 0;
+}
\f
+#ifdef GUILE_NEW_GC_SCHEME
int
-scm_init_storage (init_heap_size)
- long init_heap_size;
+scm_init_storage (scm_sizet init_heap_size, int gc_trigger,
+ scm_sizet init_heap2_size, int gc_trigger2)
+#else
+int
+scm_init_storage (scm_sizet init_heap_size, scm_sizet init_heap2_size)
+#endif
{
scm_sizet j;
while (j)
scm_sys_protects[--j] = SCM_BOOL_F;
scm_block_gc = 1;
+
+#ifdef GUILE_NEW_GC_SCHEME
scm_freelist = SCM_EOL;
+ scm_master_freelist.clusters = SCM_EOL;
+ scm_master_freelist.triggeredp = 0;
+ scm_master_freelist.gc_trigger
+ = gc_trigger ? gc_trigger : SCM_GC_TRIGGER;
+ scm_master_freelist.span = 1;
+ scm_master_freelist.collected = 0;
+ scm_master_freelist.heap_size = 0;
+#else
+ scm_freelist.cells = SCM_EOL;
+ scm_freelist.span = 1;
+ scm_freelist.collected = 0;
+ scm_freelist.heap_size = 0;
+#endif
+
+#ifdef GUILE_NEW_GC_SCHEME
+ scm_freelist2 = SCM_EOL;
+ scm_master_freelist2.clusters = SCM_EOL;
+ scm_master_freelist2.triggeredp = 0;
+ scm_master_freelist2.gc_trigger
+ = gc_trigger2 ? gc_trigger2 : SCM_GC_TRIGGER2;
+ scm_master_freelist2.span = 2;
+ scm_master_freelist2.collected = 0;
+ scm_master_freelist2.heap_size = 0;
+#else
+ scm_freelist2.cells = SCM_EOL;
+ scm_freelist2.span = 2;
+ scm_freelist2.collected = 0;
+ scm_freelist2.heap_size = 0;
+#endif
+
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_must_malloc (sizeof (struct scm_heap_seg_data) * 2, "hplims"));
+
+#ifdef GUILE_NEW_GC_SCHEME
+ if (make_initial_segment (init_heap_size, &scm_master_freelist) ||
+ make_initial_segment (init_heap2_size, &scm_master_freelist2))
+ return 1;
+#else
+ if (make_initial_segment (init_heap_size, &scm_freelist) ||
+ make_initial_segment (init_heap2_size, &scm_freelist2))
+ return 1;
+#endif
+
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;
+ scm_weak_vectors = SCM_EOL;
/* Initialise the list of ports. */
- scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table)
- * scm_port_table_room));
+ scm_port_table = (scm_port **)
+ malloc (sizeof (scm_port *) * scm_port_table_room);
if (!scm_port_table)
return 1;
+#ifdef HAVE_ATEXIT
+ atexit (cleanup);
+#else
+#ifdef HAVE_ON_EXIT
+ on_exit (cleanup, 0);
+#endif
+#endif
scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
SCM_SETCDR (scm_undefineds, scm_undefineds);
HCoop / bpt / guile.git / blobdiff