summaryrefslogtreecommitdiff
path: root/libguile/gc.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/gc.c')
-rw-r--r--libguile/gc.c1825
1 files changed, 0 insertions, 1825 deletions
diff --git a/libguile/gc.c b/libguile/gc.c
deleted file mode 100644
index cd4a249d7..000000000
--- a/libguile/gc.c
+++ /dev/null
@@ -1,1825 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "stime.h"
-#include "stackchk.h"
-#include "struct.h"
-#include "genio.h"
-#include "weaks.h"
-#include "smob.h"
-#include "unif.h"
-#include "async.h"
-
-#include "gc.h"
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
-#ifdef HAVE_UNISTD_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
-
-
-/* {heap tuning parameters}
- *
- * These are parameters for controlling memory allocation. The heap
- * is the area out of which scm_cons, and object headers are allocated.
- *
- * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
- * 64 bit machine. The units of the _SIZE parameters are bytes.
- * Cons pairs and object headers occupy one heap cell.
- *
- * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
- * allocated initially the heap will grow by half its current size
- * each subsequent time more heap is needed.
- *
- * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
- * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
- * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
- * is in scm_init_storage() and alloc_some_heap() in sys.c
- *
- * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
- * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
- *
- * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
- * is needed.
- *
- * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
- * trigger a GC.
- *
- * 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))
-#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
-#ifdef _QC
-# define SCM_HEAP_SEG_SIZE 32768L
-#else
-# ifdef sequent
-# define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
-# else
-# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
-# endif
-#endif
-#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
-#define SCM_INIT_MALLOC_LIMIT 100000
-#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 */
-
-#ifdef PROT386
-/*in 386 protected mode we must only adjust the offset */
-# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
-# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
-#else
-# ifdef _UNICOS
-# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
-# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
-# else
-# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
-# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
-# endif /* UNICOS */
-#endif /* PROT386 */
-
-
-
-/* scm_freelist
- * is the head of freelist of cons pairs.
- */
-SCM scm_freelist = SCM_EOL;
-
-/* scm_mtrigger
- * is the number of bytes of must_malloc allocation needed to trigger gc.
- */
-long scm_mtrigger;
-
-
-/* scm_gc_heap_lock
- * If set, don't expand the heap. Set only during gc, during which no allocation
- * is supposed to take place anyway.
- */
-int scm_gc_heap_lock = 0;
-
-/* GC Blocking
- * Don't pause for collection if this is set -- just
- * expand the heap.
- */
-
-int scm_block_gc = 1;
-
-/* If fewer than MIN_GC_YIELD cells are recovered during a garbage
- * collection (GC) more space is allocated for the heap.
- */
-#define MIN_GC_YIELD (scm_heap_size/4)
-
-/* During collection, this accumulates objects holding
- * weak references.
- */
-SCM *scm_weak_vectors;
-int scm_weak_size;
-int scm_n_weak;
-
-/* GC Statistics Keeping
- */
-unsigned long scm_cells_allocated = 0;
-unsigned long scm_mallocated = 0;
-unsigned long scm_gc_cells_collected;
-unsigned long scm_gc_malloc_collected;
-unsigned long scm_gc_ports_collected;
-unsigned long scm_gc_rt;
-unsigned long scm_gc_time_taken = 0;
-
-SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
-SCM_SYMBOL (sym_heap_size, "cell-heap-size");
-SCM_SYMBOL (sym_mallocated, "bytes-malloced");
-SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
-SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
-SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
-
-
-struct scm_heap_seg_data
-{
- /* 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 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 *));
-
-
-
-/* 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;
-void
-scm_debug_newcell (SCM *into)
-{
- 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 ();
- else
- {
- *into = scm_freelist;
- scm_freelist = SCM_CDR (scm_freelist);
- ++scm_cells_allocated;
- }
-}
-
-#endif /* DEBUG_FREELIST */
-
-
-
-/* {Scheme Interface to GC}
- */
-
-SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
-SCM
-scm_gc_stats ()
-{
- int i;
- int n;
- SCM heap_segs;
- SCM local_scm_mtrigger;
- SCM local_scm_mallocated;
- SCM local_scm_heap_size;
- SCM local_scm_cells_allocated;
- SCM local_scm_gc_time_taken;
- SCM answer;
-
- SCM_DEFER_INTS;
- scm_block_gc = 1;
- retry:
- heap_segs = SCM_EOL;
- n = scm_n_heap_segs;
- for (i = scm_n_heap_segs; i--; )
- heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]),
- scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])),
- heap_segs);
- if (scm_n_heap_segs != n)
- goto retry;
- scm_block_gc = 0;
-
- local_scm_mtrigger = scm_mtrigger;
- local_scm_mallocated = scm_mallocated;
- local_scm_heap_size = scm_heap_size;
- local_scm_cells_allocated = scm_cells_allocated;
- local_scm_gc_time_taken = scm_gc_time_taken;
-
- answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
- scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
- scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
- scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)),
- scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
- scm_cons (sym_heap_segments, heap_segs),
- SCM_UNDEFINED);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-void
-scm_gc_start (what)
- char *what;
-{
- scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
- scm_gc_cells_collected = 0;
- scm_gc_malloc_collected = 0;
- scm_gc_ports_collected = 0;
-}
-
-void
-scm_gc_end ()
-{
- scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
- scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
- scm_take_signal (SCM_GC_SIGNAL);
-}
-
-
-SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr);
-SCM
-scm_object_addr (obj)
- SCM obj;
-{
- return scm_ulong2num ((unsigned long)obj);
-}
-
-
-SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
-SCM
-scm_gc ()
-{
- SCM_DEFER_INTS;
- scm_igc ("call");
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-
-/* {C Interface For When GC is Triggered}
- */
-
-void
-scm_gc_for_alloc (ncells, freelistp)
- int ncells;
- SCM * freelistp;
-{
- SCM_REDEFER_INTS;
- scm_igc ("cells");
- if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp))
- {
- alloc_some_heap (ncells, freelistp);
- }
- SCM_REALLOW_INTS;
-}
-
-
-SCM
-scm_gc_for_newcell ()
-{
- SCM fl;
- scm_gc_for_alloc (1, &scm_freelist);
- fl = scm_freelist;
- scm_freelist = SCM_CDR (fl);
- return fl;
-}
-
-void
-scm_igc (what)
- char *what;
-{
- int j;
-
-#ifdef USE_THREADS
- /* During the critical section, only the current thread may run. */
- SCM_THREAD_CRITICAL_SECTION_START;
-#endif
-
- scm_gc_start (what);
- if (!scm_stack_base || scm_block_gc)
- {
- scm_gc_end ();
- return;
- }
-
- ++scm_gc_heap_lock;
- scm_n_weak = 0;
-
- /* unprotect any struct types with no instances */
-#if 0
- {
- SCM type_list;
- SCM * pos;
-
- pos = &scm_type_obj_list;
- type_list = scm_type_obj_list;
- while (type_list != SCM_EOL)
- if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt])
- {
- pos = SCM_CDRLOC (type_list);
- type_list = SCM_CDR (type_list);
- }
- else
- {
- *pos = SCM_CDR (type_list);
- type_list = SCM_CDR (type_list);
- }
- }
-#endif
-
- /* flush dead entries from the continuation stack */
- {
- int x;
- int bound;
- SCM * elts;
- elts = SCM_VELTS (scm_continuation_stack);
- bound = SCM_LENGTH (scm_continuation_stack);
- x = SCM_INUM (scm_continuation_stack_ptr);
- while (x < bound)
- {
- elts[x] = SCM_BOOL_F;
- ++x;
- }
- }
-
-#ifndef USE_THREADS
-
- /* Protect from the C stack. This must be the first marking
- * done because it provides information about what objects
- * are "in-use" by the C code. "in-use" objects are those
- * for which the values from SCM_LENGTH and SCM_CHARS must remain
- * usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_vector_set_length_x.
- */
- SCM_FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 +
- sizeof scm_save_regs_gc_mark)
- / sizeof (SCM_STACKITEM)));
-
- {
- /* stack_len is long rather than scm_sizet in order to guarantee that
- &stack_len is long aligned */
-#ifdef SCM_STACK_GROWS_UP
-#ifdef nosve
- long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base;
-#else
- long stack_len = scm_stack_size (scm_stack_base);
-#endif
- scm_mark_locations (scm_stack_base, (scm_sizet) stack_len);
-#else
-#ifdef nosve
- long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len);
-#else
- long stack_len = scm_stack_size (scm_stack_base);
-#endif
- scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len);
-#endif
- }
-
-#else /* USE_THREADS */
-
- /* Mark every thread's stack and registers */
- scm_threads_mark_stacks();
-
-#endif /* USE_THREADS */
-
- /* FIXME: insert a phase to un-protect string-data preserved
- * in scm_vector_set_length_x.
- */
-
- j = SCM_NUM_PROTECTS;
- while (j--)
- scm_gc_mark (scm_sys_protects[j]);
-
-#ifndef USE_THREADS
- scm_gc_mark (scm_root->handle);
-#endif
-
- scm_mark_weak_vector_spines ();
-
- scm_gc_sweep ();
-
- --scm_gc_heap_lock;
- scm_gc_end ();
-
-#ifdef USE_THREADS
- SCM_THREAD_CRITICAL_SECTION_END;
-#endif
-}
-
-
-/* {Mark/Sweep}
- */
-
-
-
-/* Mark an object precisely.
- */
-void
-scm_gc_mark (p)
- SCM p;
-{
- register long i;
- register SCM ptr;
-
- ptr = p;
-
-gc_mark_loop:
- if (SCM_IMP (ptr))
- return;
-
-gc_mark_nimp:
- if (SCM_NCELLP (ptr))
- scm_wta (ptr, "rogue pointer in ", "heap");
-
- switch (SCM_TYP7 (ptr))
- {
- case scm_tcs_cons_nimcar:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */
- {
- ptr = SCM_CAR (ptr);
- goto gc_mark_nimp;
- }
- scm_gc_mark (SCM_CAR (ptr));
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_nimp;
- case scm_tcs_cons_imcar:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
- case scm_tcs_cons_gloc:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- {
- SCM vcell;
- vcell = SCM_CAR (ptr) - 1L;
- switch (SCM_CDR (vcell))
- {
- default:
- scm_gc_mark (vcell);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
- case 1: /* ! */
- case 0: /* ! */
- {
- SCM layout;
- SCM * vtable_data;
- int len;
- char * fields_desc;
- register SCM * mem;
- register int x;
-
- vtable_data = (SCM *)vcell;
- layout = vtable_data[scm_struct_i_layout];
- len = SCM_LENGTH (layout);
- fields_desc = SCM_CHARS (layout);
- /* We're using SCM_GCCDR here like STRUCT_DATA, except
- that it removes the mark */
- mem = (SCM *)SCM_GCCDR (ptr);
-
- if (len)
- {
- for (x = 0; x < len - 2; x += 2, ++mem)
- if (fields_desc[x] == 'p')
- scm_gc_mark (*mem);
- if (fields_desc[x] == 'p')
- {
- if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = *mem; x; --x)
- scm_gc_mark (*++mem);
- else
- scm_gc_mark (*mem);
- }
- }
- if (!SCM_CDR (vcell))
- {
- SCM_SETGCMARK (vcell);
- ptr = vtable_data[scm_struct_i_vtable];
- goto gc_mark_loop;
- }
- }
- }
- }
- break;
- case scm_tcs_closures:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- if (SCM_IMP (SCM_CDR (ptr)))
- {
- ptr = SCM_CLOSCAR (ptr);
- goto gc_mark_nimp;
- }
- scm_gc_mark (SCM_CLOSCAR (ptr));
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_nimp;
- case scm_tc7_vector:
- case scm_tc7_lvector:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- if (SCM_GC8MARKP (ptr))
- break;
- SCM_SETGC8MARK (ptr);
- i = SCM_LENGTH (ptr);
- if (i == 0)
- break;
- while (--i > 0)
- if (SCM_NIMP (SCM_VELTS (ptr)[i]))
- scm_gc_mark (SCM_VELTS (ptr)[i]);
- ptr = SCM_VELTS (ptr)[0];
- goto gc_mark_loop;
- case scm_tc7_contin:
- if SCM_GC8MARKP
- (ptr) break;
- SCM_SETGC8MARK (ptr);
- scm_mark_locations (SCM_VELTS (ptr),
- (scm_sizet)
- (SCM_LENGTH (ptr) +
- (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) /
- sizeof (SCM_STACKITEM)));
- break;
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
-
- case scm_tc7_string:
- case scm_tc7_mb_string:
- SCM_SETGC8MARK (ptr);
- break;
-
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
-
- case scm_tc7_wvect:
- if (SCM_GC8MARKP(ptr))
- break;
- scm_weak_vectors[scm_n_weak++] = ptr;
- if (scm_n_weak >= scm_weak_size)
- {
- SCM_SYSCALL (scm_weak_vectors =
- (SCM *) realloc ((char *) scm_weak_vectors,
- sizeof (SCM *) * (scm_weak_size *= 2)));
- if (scm_weak_vectors == NULL)
- {
- scm_gen_puts (scm_regular_string,
- "weak vector table",
- scm_cur_errp);
- scm_gen_puts (scm_regular_string,
- "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
- scm_cur_errp);
- exit(SCM_EXIT_FAILURE);
- }
- }
- SCM_SETGC8MARK (ptr);
- if (SCM_IS_WHVEC_ANY (ptr))
- {
- int x;
- int len;
- int weak_keys;
- int weak_values;
-
- len = SCM_LENGTH (ptr);
- weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
- weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
-
- for (x = 0; x < len; ++x)
- {
- SCM alist;
- alist = SCM_VELTS (ptr)[x];
- /* mark everything on the alist
- * except the keys or values, according to weak_values and weak_keys.
- */
- while ( SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM kvpair;
- SCM next_alist;
-
- kvpair = SCM_CAR (alist);
- next_alist = SCM_CDR (alist);
- /*
- * Do not do this:
- * SCM_SETGCMARK (alist);
- * SCM_SETGCMARK (kvpair);
- *
- * It may be that either the key or value is protected by
- * an escaped reference to part of the spine of this alist.
- * If we mark the spine here, and only mark one or neither of the
- * key and value, they may never be properly marked.
- * This leads to a horrible situation in which an alist containing
- * freelist cells is exported.
- *
- * So only mark the spines of these arrays last of all marking.
- * If somebody confuses us by constructing a weak vector
- * with a circular alist then we are hosed, but at least we
- * won't prematurely drop table entries.
- */
- if (!weak_keys)
- scm_gc_mark (SCM_CAR (kvpair));
- if (!weak_values)
- scm_gc_mark (SCM_GCCDR (kvpair));
- alist = next_alist;
- }
- if (SCM_NIMP (alist))
- scm_gc_mark (alist);
- }
- }
- break;
-
- case scm_tc7_msymbol:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- scm_gc_mark (SCM_SYMBOL_FUNC (ptr));
- ptr = SCM_SYMBOL_PROPS (ptr);
- goto gc_mark_loop;
- case scm_tc7_ssymbol:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- break;
- case scm_tcs_subrs:
- ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8));
- goto gc_mark_loop;
- case scm_tc7_port:
- i = SCM_PTOBNUM (ptr);
- if (!(i < scm_numptob))
- goto def;
- if (SCM_GC8MARKP (ptr))
- break;
- if (SCM_PTAB_ENTRY(ptr))
- scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
- ptr = (scm_ptobs[i].mark) (ptr);
- goto gc_mark_loop;
- break;
- case scm_tc7_smob:
- if (SCM_GC8MARKP (ptr))
- break;
- switch SCM_TYP16 (ptr)
- { /* should be faster than going through scm_smobs */
- case scm_tc_free_cell:
- /* printf("found free_cell %X ", ptr); fflush(stdout); */
- SCM_SETGC8MARK (ptr);
- SCM_SETCDR (ptr, SCM_EOL);
- break;
- case scm_tcs_bignums:
- case scm_tc16_flo:
- SCM_SETGC8MARK (ptr);
- break;
- default:
- i = SCM_SMOBNUM (ptr);
- if (!(i < scm_numsmob))
- goto def;
- ptr = (scm_smobs[i].mark) (ptr);
- goto gc_mark_loop;
- }
- break;
- default:
- def:scm_wta (ptr, "unknown type in ", "gc_mark");
- }
-}
-
-
-/* Mark a Region Conservatively
- */
-
-void
-scm_mark_locations (x, n)
- SCM_STACKITEM x[];
- scm_sizet n;
-{
- register long m = n;
- register int i, j;
- register SCM_CELLPTR ptr;
-
- while (0 <= --m)
- if SCM_CELLP (*(SCM **) & x[m])
- {
- ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
- i = 0;
- j = scm_n_heap_segs - 1;
- if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- {
- while (i <= j)
- {
- int seg_id;
- seg_id = -1;
- if ( (i == j)
- || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
- seg_id = i;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- seg_id = j;
- else
- {
- int k;
- k = (i + j) / 2;
- if (k == i)
- break;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
- {
- j = k;
- ++i;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
- continue;
- else
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- continue;
- else
- break;
- }
- }
- if ( !scm_heap_table[seg_id].valid
- || scm_heap_table[seg_id].valid (ptr,
- &scm_heap_table[seg_id]))
- scm_gc_mark (*(SCM *) & x[m]);
- break;
- }
-
- }
- }
-}
-
-
-/* The following is a C predicate which determines if an SCM value can be
- regarded as a pointer to a cell on the heap. The code is duplicated
- from scm_mark_locations. */
-
-
-int
-scm_cellp (value)
- SCM value;
-{
- register int i, j;
- register SCM_CELLPTR ptr;
-
- if SCM_CELLP (*(SCM **) & value)
- {
- ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
- i = 0;
- j = scm_n_heap_segs - 1;
- if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- {
- while (i <= j)
- {
- int seg_id;
- seg_id = -1;
- if ( (i == j)
- || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
- seg_id = i;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- seg_id = j;
- else
- {
- int k;
- k = (i + j) / 2;
- if (k == i)
- break;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
- {
- j = k;
- ++i;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
- continue;
- else
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- continue;
- else
- break;
- }
- }
- if ( !scm_heap_table[seg_id].valid
- || scm_heap_table[seg_id].valid (ptr,
- &scm_heap_table[seg_id]))
- return 1;
- break;
- }
-
- }
- }
- return 0;
-}
-
-
-static void
-scm_mark_weak_vector_spines ()
-{
- int i;
-
- for (i = 0; i < scm_n_weak; ++i)
- {
- if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
- {
- SCM *ptr;
- SCM obj;
- int j;
- int n;
-
- obj = scm_weak_vectors[i];
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- {
- SCM alist;
-
- alist = ptr[j];
- while ( SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM_SETGCMARK (alist);
- SCM_SETGCMARK (SCM_CAR (alist));
- alist = SCM_GCCDR (alist);
- }
- }
- }
- }
-}
-
-
-
-void
-scm_gc_sweep ()
-{
- register SCM_CELLPTR ptr;
-#ifdef SCM_POINTERS_MUNGED
- register SCM scmptr;
-#else
-#undef scmptr
-#define scmptr (SCM)ptr
-#endif
- register SCM nfreelist;
- register SCM *hp_freelist;
- register long n;
- register long m;
- register scm_sizet j;
- register int span;
- scm_sizet i;
- scm_sizet seg_size;
-
- n = 0;
- m = 0;
-
- /* 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++)
- {
- /* 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 = *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;
- for (j = seg_size + span; j -= span; ptr += span)
- {
-#ifdef SCM_POINTERS_MUNGED
- scmptr = PTR2SCM (ptr);
-#endif
- switch SCM_TYP7 (scmptr)
- {
- case scm_tcs_cons_gloc:
- if (SCM_GCMARKP (scmptr))
- {
- if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1)
- SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0);
- goto cmrkcontinue;
- }
- {
- SCM vcell;
- vcell = SCM_CAR (scmptr) - 1L;
-
- if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
- {
- SCM *p = (SCM *) SCM_GCCDR (scmptr);
- m += p[scm_struct_i_n_words] * sizeof (SCM);
- /* I feel like I'm programming in BCPL here... */
- free ((char *) p[scm_struct_i_ptr]);
- }
- }
- break;
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- case scm_tcs_closures:
- if (SCM_GCMARKP (scmptr))
- goto cmrkcontinue;
- break;
- case scm_tc7_wvect:
- if (SCM_GC8MARKP (scmptr))
- {
- goto c8mrkcontinue;
- }
- else
- {
- m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM);
- scm_must_free ((char *)(SCM_VELTS (scmptr) - 1));
- break;
- }
-
- case scm_tc7_vector:
- case scm_tc7_lvector:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
-
- m += (SCM_LENGTH (scmptr) * sizeof (SCM));
- freechars:
- scm_must_free (SCM_CHARS (scmptr));
- /* SCM_SETCHARS(scmptr, 0);*/
- break;
- case scm_tc7_bvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- goto freechars;
- case scm_tc7_byvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (char);
- goto freechars;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (long);
- goto freechars;
- case scm_tc7_svect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
- goto freechars;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long);
- goto freechars;
-#endif
- case scm_tc7_fvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (float);
- goto freechars;
- case scm_tc7_dvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (double);
- goto freechars;
- case scm_tc7_cvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
- goto freechars;
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- break;
- case scm_tc7_string:
- case scm_tc7_mb_string:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) + 1;
- goto freechars;
- case scm_tc7_msymbol:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- m += ( SCM_LENGTH (scmptr)
- + 1
- + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr)));
- scm_must_free ((char *)SCM_SLOTS (scmptr));
- break;
- case scm_tc7_contin:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
- goto freechars;
- case scm_tc7_ssymbol:
- if SCM_GC8MARKP(scmptr)
- goto c8mrkcontinue;
- break;
- case scm_tcs_subrs:
- continue;
- case scm_tc7_port:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- if SCM_OPENP (scmptr)
- {
- int k = SCM_PTOBNUM (scmptr);
- if (!(k < scm_numptob))
- goto sweeperr;
- /* Keep "revealed" ports alive. */
- if (scm_revealed_count(scmptr) > 0)
- continue;
- /* Yes, I really do mean scm_ptobs[k].free */
- /* rather than ftobs[k].close. .close */
- /* is for explicit CLOSE-PORT by user */
- (scm_ptobs[k].free) (SCM_STREAM (scmptr));
- SCM_SETSTREAM (scmptr, 0);
- scm_remove_from_port_table (scmptr);
- scm_gc_ports_collected++;
- SCM_SETAND_CAR (scmptr, ~SCM_OPN);
- }
- break;
- case scm_tc7_smob:
- switch SCM_GCTYP16 (scmptr)
- {
- case scm_tc_free_cell:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- break;
-#ifdef SCM_BIGDIG
- case scm_tcs_bignums:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT);
- goto freechars;
-#endif /* def SCM_BIGDIG */
- case scm_tc16_flo:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- switch ((int) (SCM_CAR (scmptr) >> 16))
- {
- case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
- m += sizeof (double);
- case SCM_REAL_PART >> 16:
- case SCM_IMAG_PART >> 16:
- m += sizeof (double);
- goto freechars;
- case 0:
- break;
- default:
- goto sweeperr;
- }
- break;
- default:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
-
- {
- int k;
- k = SCM_SMOBNUM (scmptr);
- if (!(k < scm_numsmob))
- goto sweeperr;
- m += (scm_smobs[k].free) ((SCM) scmptr);
- break;
- }
- }
- break;
- default:
- sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep");
- }
- n += span;
-#if 0
- if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
- exit (2);
-#endif
- /* Stick the new cell on the front of nfreelist. */
- SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
- SCM_SETCDR (scmptr, nfreelist);
- nfreelist = scmptr;
-
- continue;
- c8mrkcontinue:
- SCM_CLRGC8MARK (scmptr);
- continue;
- cmrkcontinue:
- SCM_CLRGCMARK (scmptr);
- }
-#ifdef GC_FREE_SEGMENTS
- if (n == seg_size)
- {
- scm_heap_size -= seg_size;
- free ((char *) scm_heap_table[i].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--; /* 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. */
- {
- SCM *ptr;
- for (i = 0; i < scm_n_weak; ++i)
- {
- if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
- {
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j]))
- ptr[j] = SCM_BOOL_F;
- }
- else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
- {
- SCM obj;
- obj = scm_weak_vectors[i];
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- {
- SCM * fixup;
- SCM alist;
- int weak_keys;
- int weak_values;
-
- weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
- weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
-
- fixup = ptr + j;
- alist = *fixup;
-
- while (SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM key;
- SCM value;
-
- key = SCM_CAAR (alist);
- value = SCM_CDAR (alist);
- if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key))
- || (weak_values && SCM_NIMP (value) && SCM_FREEP (value)))
- {
- *fixup = SCM_CDR (alist);
- }
- else
- fixup = SCM_CDRLOC (alist);
- alist = SCM_CDR (alist);
- }
- }
- }
- }
- }
- scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
- scm_mallocated -= m;
- scm_gc_malloc_collected = m;
-}
-
-
-
-
-/* {Front end to malloc}
- *
- * scm_must_malloc, scm_must_realloc, scm_must_free
- *
- * These functions provide services comperable to malloc, realloc, and
- * free. They are for allocating malloced parts of scheme objects.
- * The primary purpose of the front end is to impose calls to gc.
- */
-
-/* scm_must_malloc
- * Return newly malloced storage or throw an error.
- *
- * The parameter WHAT is a string for error reporting.
- * If the threshold scm_mtrigger will be passed by this
- * allocation, or if the first call to malloc fails,
- * garbage collect -- on the presumption that some objects
- * using malloced storage may be collected.
- *
- * The limit scm_mtrigger may be raised by this allocation.
- */
-char *
-scm_must_malloc (len, what)
- long len;
- char *what;
-{
- char *ptr;
- scm_sizet size = len;
- long nm = scm_mallocated + size;
- if (len != size)
- malerr:
- scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
- if ((nm <= scm_mtrigger))
- {
- SCM_SYSCALL (ptr = (char *) malloc (size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- return ptr;
- }
- }
-
- scm_igc (what);
- nm = scm_mallocated + size;
- SCM_SYSCALL (ptr = (char *) malloc (size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
- else
- scm_mtrigger += scm_mtrigger / 2;
- }
- return ptr;
- }
- goto malerr;
-}
-
-
-/* scm_must_realloc
- * is similar to scm_must_malloc.
- */
-char *
-scm_must_realloc (where, olen, len, what)
- char *where;
- long olen;
- long len;
- char *what;
-{
- char *ptr;
- scm_sizet size = len;
- long nm = scm_mallocated + size - olen;
- if (len != size)
- ralerr:
- scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
- if ((nm <= scm_mtrigger))
- {
- SCM_SYSCALL (ptr = (char *) realloc (where, size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- return ptr;
- }
- }
- scm_igc (what);
- nm = scm_mallocated + size - olen;
- SCM_SYSCALL (ptr = (char *) realloc (where, size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
- else
- scm_mtrigger += scm_mtrigger / 2;
- }
- return ptr;
- }
- goto ralerr;
-}
-
-void
-scm_must_free (obj)
- char *obj;
-{
- if (obj)
- free (obj);
- else
- scm_wta (SCM_INUM0, "already free", "");
-}
-
-
-
-
-/* {Heap Segments}
- *
- * Each heap segment is an array of objects of a particular size.
- * Every segment has an associated (possibly shared) freelist.
- * A table of segment records is kept that records the upper and
- * lower extents of the segment; this is used during the conservative
- * phase of gc to identify probably gc roots (because they point
- * into valid segments at reasonable offsets).
- */
-
-/* scm_expmem
- * is true if the first segment was smaller than INIT_HEAP_SEG.
- * If scm_expmem is set to one, subsequent segment allocations will
- * allocate segments of size SCM_EXPHEAP(scm_heap_size).
- */
-int scm_expmem = 0;
-
-/* scm_heap_org
- * is the lowest base address of any heap segment.
- */
-SCM_CELLPTR scm_heap_org;
-
-struct scm_heap_seg_data * scm_heap_table = 0;
-int scm_n_heap_segs = 0;
-
-/* scm_heap_size
- * is the total number of cells in heap segments.
- */
-long scm_heap_size = 0;
-
-/* init_heap_seg
- * initializes a new heap segment and return the number of objects it contains.
- *
- * The segment origin, segment size in bytes, and the span of objects
- * in cells are input parameters. The freelist is both input and output.
- *
- * This function presume that the scm_heap_table has already been expanded
- * to accomodate a new segment record.
- */
-
-
-static scm_sizet
-init_heap_seg (seg_org, size, ncells, freelistp)
- SCM_CELLPTR seg_org;
- scm_sizet size;
- int ncells;
- SCM *freelistp;
-{
- register SCM_CELLPTR ptr;
-#ifdef SCM_POINTERS_MUNGED
- register SCM scmptr;
-#else
-#undef scmptr
-#define scmptr ptr
-#endif
- SCM_CELLPTR seg_end;
- scm_sizet new_seg_index;
- scm_sizet n_new_objects;
-
- if (seg_org == NULL)
- return 0;
-
- ptr = seg_org;
-
- /* Compute the ceiling on valid object pointers w/in this segment.
- */
- seg_end = CELL_DN ((char *) ptr + size);
-
- /* Find the right place and insert the segment record.
- *
- */
- for (new_seg_index = 0;
- ( (new_seg_index < scm_n_heap_segs)
- && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
- new_seg_index++)
- ;
-
- {
- int i;
- for (i = scm_n_heap_segs; i > new_seg_index; --i)
- scm_heap_table[i] = scm_heap_table[i - 1];
- }
-
- ++scm_n_heap_segs;
-
- scm_heap_table[new_seg_index].valid = 0;
- scm_heap_table[new_seg_index].ncells = ncells;
- scm_heap_table[new_seg_index].freelistp = freelistp;
- scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr;
- scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end;
-
-
- /* Compute the least valid object pointer w/in this segment
- */
- ptr = CELL_UP (ptr);
-
-
- n_new_objects = seg_end - ptr;
-
- /* Prepend objects in this segment to the freelist.
- */
- while (ptr < seg_end)
- {
-#ifdef SCM_POINTERS_MUNGED
- scmptr = PTR2SCM (ptr);
-#endif
- SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
- SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
- ptr += ncells;
- }
-
- ptr -= ncells;
-
- /* Patch up the last freelist pointer in the segment
- * to join it to the input freelist.
- */
- SCM_SETCDR (PTR2SCM (ptr), *freelistp);
- *freelistp = PTR2SCM (CELL_UP (seg_org));
-
- scm_heap_size += (ncells * n_new_objects);
- return size;
-#ifdef scmptr
-#undef scmptr
-#endif
-}
-
-
-static void
-alloc_some_heap (ncells, freelistp)
- int ncells;
- SCM * freelistp;
-{
- struct scm_heap_seg_data * tmptable;
- SCM_CELLPTR ptr;
- scm_sizet len;
-
- /* Critical code sections (such as the garbage collector)
- * aren't supposed to add heap segments.
- */
- if (scm_gc_heap_lock)
- scm_wta (SCM_UNDEFINED, "need larger initial", "heap");
-
- /* Expand the heap tables to have room for the new segment.
- * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
- * only if the allocation of the segment itself succeeds.
- */
- len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data);
-
- SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *)
- realloc ((char *)scm_heap_table, len)));
- if (!tmptable)
- scm_wta (SCM_UNDEFINED, "could not grow", "hplims");
- else
- scm_heap_table = tmptable;
-
-
- /* Pick a size for the new heap segment.
- * The rule for picking the size of a segment is explained in
- * gc.h
- */
- if (scm_expmem)
- {
- len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell));
- if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
- len = 0;
- }
- else
- len = SCM_HEAP_SEG_SIZE;
-
- {
- scm_sizet smallest;
-
- smallest = (ncells * sizeof (scm_cell));
- if (len < smallest)
- len = (ncells * sizeof (scm_cell));
-
- /* Allocate with decaying ambition. */
- while ((len >= SCM_MIN_HEAP_SEG_SIZE)
- && (len >= smallest))
- {
- SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
- if (ptr)
- {
- init_heap_seg (ptr, len, ncells, freelistp);
- return;
- }
- len /= 2;
- }
- }
-
- scm_wta (SCM_UNDEFINED, "could not grow", "heap");
-}
-
-
-
-SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
-SCM
-scm_unhash_name (name)
- SCM name;
-{
- int x;
- int bound;
- SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
- SCM_DEFER_INTS;
- bound = scm_n_heap_segs;
- for (x = 0; x < bound; ++x)
- {
- SCM_CELLPTR p;
- SCM_CELLPTR pbound;
- p = (SCM_CELLPTR)scm_heap_table[x].bounds[0];
- pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1];
- while (p < pbound)
- {
- SCM incar;
- incar = p->car;
- if (1 == (7 & (int)incar))
- {
- --incar;
- if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
- && (SCM_CDR (incar) != 0)
- && (SCM_CDR (incar) != 1))
- {
- p->car = name;
- }
- }
- ++p;
- }
- }
- SCM_ALLOW_INTS;
- return name;
-}
-
-
-
-/* {GC Protection Helper Functions}
- */
-
-
-void
-scm_remember (ptr)
- SCM * ptr;
-{}
-
-
-#ifdef __STDC__
-SCM
-scm_return_first (SCM elt, ...)
-#else
-SCM
-scm_return_first (elt, va_alist)
- SCM elt;
- va_dcl
-#endif
-{
- return elt;
-}
-
-
-SCM
-scm_permanent_object (obj)
- SCM obj;
-{
- SCM_REDEFER_INTS;
- scm_permobjs = scm_cons (obj, scm_permobjs);
- SCM_REALLOW_INTS;
- return obj;
-}
-
-
-
-int
-scm_init_storage (init_heap_size)
- long init_heap_size;
-{
- scm_sizet j;
-
- j = SCM_NUM_PROTECTS;
- while (j)
- scm_sys_protects[--j] = SCM_BOOL_F;
- scm_block_gc = 1;
- scm_freelist = SCM_EOL;
- scm_expmem = 0;
-
- j = SCM_HEAP_SEG_SIZE;
- scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
- scm_heap_table = ((struct scm_heap_seg_data *)
- scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims"));
- if (0L == init_heap_size)
- init_heap_size = SCM_INIT_HEAP_SIZE;
- j = init_heap_size;
- if ((init_heap_size != j)
- || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
- {
- j = SCM_HEAP_SEG_SIZE;
- if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
- return 1;
- }
- else
- scm_expmem = 1;
- scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
- /* scm_hplims[0] can change. do not remove scm_heap_org */
- if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *))))
- return 1;
-
- /* Initialise the list of ports. */
- scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table)
- * scm_port_table_room));
- if (!scm_port_table)
- return 1;
-
-
- scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
- SCM_SETCDR (scm_undefineds, scm_undefineds);
-
- scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
- scm_nullstr = scm_makstr (0L, 0);
- scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED);
- scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
- scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
- scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
- scm_stand_in_procs = SCM_EOL;
- scm_permobjs = SCM_EOL;
- scm_asyncs = SCM_EOL;
- scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
- scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
-#ifdef SCM_BIGDIG
- scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD));
-#endif
- return 0;
-}
-
-
-void
-scm_init_gc ()
-{
-#include "gc.x"
-}