mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-03 10:40:21 +02:00
new gc
This commit is contained in:
Han-Wen Nienhuys
parent
c3164ca85e
commit
c8a1bdc460
19 changed files with 796 additions and 2287 deletions
|
|
@ -1,3 +1,13 @@
|
|||
2002-08-04 Han-Wen <hanwen@cs.uu.nl>
|
||||
|
||||
* numbers.c (big2str): return "0" for 0 iso. ""
|
||||
|
||||
* gc-segment.c, gc-malloc.c gc-mark.c, gc-freelist.c, gc-card.c, private-gc.h:
|
||||
new file
|
||||
|
||||
* gc.c: completely revised and cleaned up the GC. It now uses lazy
|
||||
sweeping. More documentation in workbook/newgc.text
|
||||
|
||||
2002-07-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
|
||||
|
||||
* random.c (rstate_free): Return zero.
|
||||
|
|
|
|||
|
|
@ -64,7 +64,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
|
|||
chars.c continuations.c convert.c debug.c deprecation.c \
|
||||
dynwind.c environments.c eq.c error.c eval.c evalext.c extensions.c \
|
||||
feature.c fluids.c fports.c \
|
||||
gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \
|
||||
gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c gc-freelist.c \
|
||||
gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \
|
||||
gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \
|
||||
hashtab.c hooks.c init.c inline.c ioext.c iselect.c keywords.c \
|
||||
lang.c list.c \
|
||||
|
|
@ -79,7 +80,7 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
|
|||
continuations.x debug.x deprecation.x dynl.x dynwind.x \
|
||||
environments.x eq.x \
|
||||
error.x eval.x evalext.x extensions.x feature.x fluids.x fports.x \
|
||||
gc.x goops.x \
|
||||
gc.x gc-mark.x gc-segment.x gc-malloc.x gc-card.x goops.x \
|
||||
gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \
|
||||
keywords.x lang.x list.x load.x macros.x mallocs.x modules.x \
|
||||
numbers.x objects.x objprop.x options.x pairs.x ports.x print.x \
|
||||
|
|
@ -95,7 +96,7 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
|
|||
boolean.doc chars.doc continuations.doc debug.doc dynl.doc \
|
||||
dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \
|
||||
extensions.doc feature.doc fluids.doc fports.doc gc.doc goops.doc \
|
||||
gsubr.doc \
|
||||
gsubr.doc gc-mark.doc gc-segment.doc gc-malloc.doc gc-card.doc \
|
||||
guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \
|
||||
iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \
|
||||
mallocs.doc modules.doc numbers.doc objects.doc objprop.doc \
|
||||
|
|
@ -130,7 +131,8 @@ install-exec-hook:
|
|||
## working.
|
||||
noinst_HEADERS = coop-threads.c coop-threads.h coop.c \
|
||||
num2integral.i.c num2float.i.c convert.i.c \
|
||||
win32-uname.h win32-dirent.h win32-socket.h
|
||||
win32-uname.h win32-dirent.h win32-socket.h\
|
||||
private-gc.h
|
||||
|
||||
libguile_la_DEPENDENCIES = @LIBLOBJS@
|
||||
libguile_la_LIBADD = @LIBLOBJS@ $(LIBLTDL) $(THREAD_LIBS_LOCAL)
|
||||
|
|
|
|||
|
|
@ -270,7 +270,7 @@ scm_dynthrow (SCM cont, SCM val)
|
|||
grow_stack (cont, val);
|
||||
#else
|
||||
dst -= continuation->num_stack_items;
|
||||
if (SCM_PTR_LE (dst, &stack_top_element))
|
||||
if (dst <= &stack_top_element)
|
||||
grow_stack (cont, val);
|
||||
#endif /* def SCM_STACK_GROWS_UP */
|
||||
|
||||
|
|
|
|||
337
libguile/gc-card.c
Normal file
337
libguile/gc-card.c
Normal file
|
|
@ -0,0 +1,337 @@
|
|||
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 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, 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.
|
||||
*
|
||||
* 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 "libguile/_scm.h"
|
||||
#include "libguile/eval.h"
|
||||
#include "libguile/stime.h"
|
||||
#include "libguile/stackchk.h"
|
||||
#include "libguile/struct.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/unif.h"
|
||||
#include "libguile/async.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/weaks.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/tags.h"
|
||||
#include "libguile/private-gc.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/deprecation.h"
|
||||
#include "libguile/gc.h"
|
||||
|
||||
|
||||
#include "libguile/private-gc.h"
|
||||
|
||||
long int scm_i_deprecated_memory_return;
|
||||
|
||||
|
||||
/*
|
||||
Init all the free cells in CARD, prepending to *FREE_LIST.
|
||||
|
||||
Return: number of free cells found in this card.
|
||||
|
||||
It would be cleaner to have a separate function sweep_value(), but
|
||||
that is too slow (functions with switch statements can't be
|
||||
inlined).
|
||||
|
||||
*/
|
||||
|
||||
int
|
||||
scm_i_sweep_card (scm_t_cell * p, SCM *free_list, int span)
|
||||
#define FUNC_NAME "sweep_card"
|
||||
{
|
||||
scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
|
||||
scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
|
||||
int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
|
||||
int free_count = 0;
|
||||
|
||||
/*
|
||||
I tried something fancy with shifting by one bit every word from
|
||||
the bitvec in turn, but it wasn't any faster, but quite bit
|
||||
hairier.
|
||||
*/
|
||||
for (p += offset; p < end; p += span, offset += span)
|
||||
{
|
||||
SCM scmptr = PTR2SCM(p);
|
||||
if (SCM_C_BVEC_GET (bitvec, offset))
|
||||
continue;
|
||||
|
||||
switch (SCM_TYP7 (scmptr))
|
||||
{
|
||||
case scm_tcs_struct:
|
||||
{
|
||||
/* Structs need to be freed in a special order.
|
||||
* This is handled by GC C hooks in struct.c.
|
||||
*/
|
||||
SCM_SET_STRUCT_GC_CHAIN (p, scm_structs_to_free);
|
||||
scm_structs_to_free = scmptr;
|
||||
}
|
||||
continue;
|
||||
|
||||
case scm_tcs_cons_imcar:
|
||||
case scm_tcs_cons_nimcar:
|
||||
case scm_tcs_closures:
|
||||
case scm_tc7_pws:
|
||||
break;
|
||||
case scm_tc7_wvect:
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
unsigned long int length = SCM_VECTOR_LENGTH (scmptr);
|
||||
if (length > 0)
|
||||
{
|
||||
scm_gc_free (SCM_VECTOR_BASE (scmptr),
|
||||
length * sizeof (scm_t_bits),
|
||||
"vector");
|
||||
}
|
||||
break;
|
||||
}
|
||||
#ifdef CCLO
|
||||
case scm_tc7_cclo:
|
||||
scm_gc_free (SCM_CCLO_BASE (scmptr),
|
||||
SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
|
||||
"compiled closure");
|
||||
break;
|
||||
#endif
|
||||
#ifdef HAVE_ARRAYS
|
||||
case scm_tc7_bvect:
|
||||
{
|
||||
unsigned long int length = SCM_BITVECTOR_LENGTH (scmptr);
|
||||
if (length > 0)
|
||||
{
|
||||
scm_gc_free (SCM_BITVECTOR_BASE (scmptr),
|
||||
(sizeof (long)
|
||||
* ((length+SCM_LONG_BIT-1) / SCM_LONG_BIT)),
|
||||
"vector");
|
||||
}
|
||||
}
|
||||
break;
|
||||
case scm_tc7_byvect:
|
||||
case scm_tc7_ivect:
|
||||
case scm_tc7_uvect:
|
||||
case scm_tc7_svect:
|
||||
#ifdef HAVE_LONG_LONGS
|
||||
case scm_tc7_llvect:
|
||||
#endif
|
||||
case scm_tc7_fvect:
|
||||
case scm_tc7_dvect:
|
||||
case scm_tc7_cvect:
|
||||
scm_gc_free (SCM_UVECTOR_BASE (scmptr),
|
||||
(SCM_UVECTOR_LENGTH (scmptr)
|
||||
* scm_uniform_element_size (scmptr)),
|
||||
"vector");
|
||||
break;
|
||||
#endif
|
||||
case scm_tc7_string:
|
||||
scm_gc_free (SCM_STRING_CHARS (scmptr),
|
||||
SCM_STRING_LENGTH (scmptr) + 1, "string");
|
||||
break;
|
||||
case scm_tc7_symbol:
|
||||
scm_gc_free (SCM_SYMBOL_CHARS (scmptr),
|
||||
SCM_SYMBOL_LENGTH (scmptr) + 1, "symbol");
|
||||
break;
|
||||
case scm_tc7_variable:
|
||||
break;
|
||||
case scm_tcs_subrs:
|
||||
/* the various "subrs" (primitives) are never freed */
|
||||
continue;
|
||||
case scm_tc7_port:
|
||||
if SCM_OPENP (scmptr)
|
||||
{
|
||||
int k = SCM_PTOBNUM (scmptr);
|
||||
size_t mm;
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (!(k < scm_numptob))
|
||||
SCM_MISC_ERROR ("undefined port type", SCM_EOL);
|
||||
#endif
|
||||
/* 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 */
|
||||
mm = scm_ptobs[k].free (scmptr);
|
||||
|
||||
if (mm != 0)
|
||||
{
|
||||
#if SCM_ENABLE_DEPRECATED == 1
|
||||
scm_c_issue_deprecation_warning
|
||||
("Returning non-0 from a port free function is "
|
||||
"deprecated. Use scm_gc_free et al instead.");
|
||||
scm_c_issue_deprecation_warning_fmt
|
||||
("(You just returned non-0 while freeing a %s.)",
|
||||
SCM_PTOBNAME (k));
|
||||
scm_i_deprecated_memory_return += mm;
|
||||
#else
|
||||
abort ();
|
||||
#endif
|
||||
}
|
||||
|
||||
SCM_SETSTREAM (scmptr, 0);
|
||||
scm_remove_from_port_table (scmptr);
|
||||
scm_gc_ports_collected++;
|
||||
SCM_CLR_PORT_OPEN_FLAG (scmptr);
|
||||
}
|
||||
break;
|
||||
case scm_tc7_smob:
|
||||
switch SCM_TYP16 (scmptr)
|
||||
{
|
||||
case scm_tc_free_cell:
|
||||
case scm_tc16_real:
|
||||
break;
|
||||
#ifdef SCM_BIGDIG
|
||||
case scm_tc16_big:
|
||||
scm_gc_free (SCM_BDIGITS (scmptr),
|
||||
((SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG
|
||||
/ SCM_CHAR_BIT)), "bignum");
|
||||
break;
|
||||
#endif /* def SCM_BIGDIG */
|
||||
case scm_tc16_complex:
|
||||
scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double),
|
||||
"complex");
|
||||
break;
|
||||
default:
|
||||
{
|
||||
int k;
|
||||
k = SCM_SMOBNUM (scmptr);
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (!(k < scm_numsmob))
|
||||
SCM_MISC_ERROR ("undefined smob type", SCM_EOL);
|
||||
#endif
|
||||
if (scm_smobs[k].free)
|
||||
{
|
||||
size_t mm;
|
||||
mm = scm_smobs[k].free (scmptr);
|
||||
if (mm != 0)
|
||||
{
|
||||
#if SCM_ENABLE_DEPRECATED == 1
|
||||
scm_c_issue_deprecation_warning
|
||||
("Returning non-0 from a smob free function is "
|
||||
"deprecated. Use scm_gc_free et al instead.");
|
||||
scm_c_issue_deprecation_warning_fmt
|
||||
("(You just returned non-0 while freeing a %s.)",
|
||||
SCM_SMOBNAME (k));
|
||||
scm_i_deprecated_memory_return += mm;
|
||||
#else
|
||||
abort();
|
||||
#endif
|
||||
}
|
||||
}
|
||||
break;
|
||||
}
|
||||
}
|
||||
break;
|
||||
default:
|
||||
SCM_MISC_ERROR ("unknown type", SCM_EOL);
|
||||
}
|
||||
|
||||
|
||||
SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
|
||||
SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
|
||||
*free_list = PTR2SCM (p);
|
||||
free_count ++;
|
||||
}
|
||||
return free_count;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
/*
|
||||
Like sweep, but no complicated logic to do the sweeping.
|
||||
*/
|
||||
int
|
||||
scm_init_card_freelist (scm_t_cell * card, SCM *free_list, int span)
|
||||
{
|
||||
scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
|
||||
scm_t_cell *p = end - span;
|
||||
|
||||
/*
|
||||
ASSUMPTION: n_header_cells <= 2.
|
||||
*/
|
||||
for (; p > card; p -= span)
|
||||
{
|
||||
SCM_SET_CELL_TYPE (p, scm_tc_free_cell);
|
||||
SCM_SET_FREE_CELL_CDR (p, PTR2SCM (*free_list));
|
||||
*free_list = PTR2SCM (p);
|
||||
}
|
||||
|
||||
return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
|
||||
}
|
||||
|
||||
|
||||
#if 0
|
||||
/*
|
||||
These functions are meant to be called from GDB as a debug aid.
|
||||
|
||||
I've left them as a convenience for future generations.
|
||||
*/
|
||||
|
||||
|
||||
int scm_gc_marked_p (SCM obj);
|
||||
scm_t_cell * scm_gc_get_card (SCM obj);
|
||||
long * scm_gc_get_bvec (SCM obj);
|
||||
|
||||
typedef struct scm_t_list_cell_struct {
|
||||
scm_t_bits car;
|
||||
struct scm_t_list_cell_struct * cdr;
|
||||
} scm_t_list_cell;
|
||||
|
||||
int
|
||||
scm_gc_marked_p (SCM obj)
|
||||
{
|
||||
return SCM_GC_MARK_P(obj);
|
||||
}
|
||||
|
||||
scm_t_cell *
|
||||
scm_gc_get_card (SCM obj)
|
||||
{
|
||||
return SCM_GC_CELL_CARD(obj);
|
||||
}
|
||||
|
||||
long *
|
||||
scm_gc_get_bvec (SCM obj)
|
||||
{
|
||||
return SCM_GC_CARD_BVEC(SCM_GC_CELL_CARD(obj));
|
||||
}
|
||||
#endif
|
||||
2359
libguile/gc.c
2359
libguile/gc.c
File diff suppressed because it is too large
Load diff
149
libguile/gc.h
149
libguile/gc.h
|
|
@ -58,11 +58,17 @@ typedef struct scm_t_cell
|
|||
scm_t_bits word_1;
|
||||
} scm_t_cell;
|
||||
|
||||
/*
|
||||
CARDS
|
||||
|
||||
A card is a small `page' of memory; it will be the unit for lazy
|
||||
sweeping, generations, etc. The first cell of a card contains a
|
||||
pointer to the mark bitvector, so that we can find the bitvector efficiently: we
|
||||
knock off some lowerorder bits.
|
||||
|
||||
The size on a 32 bit machine is 256 cells = 2kb. The card
|
||||
*/
|
||||
|
||||
/* SCM_CELLPTR is a pointer to a cons cell which may be compared or
|
||||
* differenced.
|
||||
*/
|
||||
typedef scm_t_cell * SCM_CELLPTR;
|
||||
|
||||
|
||||
/* Cray machines have pointers that are incremented once for each word,
|
||||
|
|
@ -73,39 +79,32 @@ typedef scm_t_cell * SCM_CELLPTR;
|
|||
* pointers to scm_vector elts, functions, &c are not munged.
|
||||
*/
|
||||
#ifdef _UNICOS
|
||||
# define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x) >> 3))
|
||||
# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
|
||||
# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
|
||||
#else
|
||||
# define SCM2PTR(x) ((SCM_CELLPTR) (SCM_UNPACK (x)))
|
||||
# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
|
||||
# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
|
||||
#endif /* def _UNICOS */
|
||||
|
||||
|
||||
#define SCM_GC_CARD_N_HEADER_CELLS 1
|
||||
#define SCM_GC_CARD_N_CELLS 256
|
||||
#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
|
||||
|
||||
#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_limb *) ((card)->word_0))
|
||||
#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
|
||||
#define SCM_GC_SET_CARD_BVEC(card, bvec) \
|
||||
((card)->word_0 = (scm_t_bits) (bvec))
|
||||
|
||||
|
||||
#define SCM_GC_CARD_SIZE (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell))
|
||||
#define SCM_GC_CARD_N_DATA_CELLS (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
|
||||
|
||||
#define SCM_GC_CARD_BVEC_SIZE_IN_LIMBS \
|
||||
((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LIMB_BITS - 1) / SCM_C_BVEC_LIMB_BITS)
|
||||
|
||||
#define SCM_GC_IN_CARD_HEADERP(x) \
|
||||
SCM_PTR_LT ((scm_t_cell *) (x), SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS)
|
||||
|
||||
#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
|
||||
#define SCM_GC_SET_CARD_FLAGS(card, flags) \
|
||||
((card)->word_1 = (scm_t_bits) (flags))
|
||||
#define SCM_GC_CLR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L))
|
||||
#define SCM_GC_CLEAR_CARD_FLAGS(card) (SCM_GC_SET_CARD_FLAGS (card, 0L))
|
||||
|
||||
#define SCM_GC_GET_CARD_FLAG(card, shift) (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
|
||||
#define SCM_GC_SET_CARD_FLAG(card, shift) \
|
||||
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
|
||||
#define SCM_GC_CLR_CARD_FLAG(card, shift) \
|
||||
#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
|
||||
(SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
|
||||
|
||||
#define SCM_GC_CARDF_DOUBLECELL 0
|
||||
|
|
@ -116,31 +115,31 @@ typedef scm_t_cell * SCM_CELLPTR;
|
|||
/* card addressing. for efficiency, cards are *always* aligned to
|
||||
SCM_GC_CARD_SIZE. */
|
||||
|
||||
#define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_SIZE - 1)
|
||||
#define SCM_GC_CARD_SIZE_MASK (SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell) - 1)
|
||||
#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
|
||||
|
||||
#define SCM_GC_CELL_CARD(x) ((SCM_CELLPTR) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
|
||||
#define SCM_GC_CELL_SPAN(x) ((SCM_GC_CARD_DOUBLECELLP (SCM_GC_CELL_CARD (x))) ? 2 : 1)
|
||||
#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
|
||||
#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
|
||||
#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
|
||||
#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
#define SCM_GC_CELL_CLR_BIT(x) SCM_C_BVEC_CLR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
|
||||
|
||||
#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_CARD_SIZE - 1)
|
||||
#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
|
||||
#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
|
||||
|
||||
/* low level bit banging aids */
|
||||
|
||||
typedef unsigned long scm_t_c_bvec_limb;
|
||||
typedef unsigned long scm_t_c_bvec_long;
|
||||
|
||||
#if (SIZEOF_LONG == 8)
|
||||
# define SCM_C_BVEC_LIMB_BITS 64
|
||||
# define SCM_C_BVEC_LONG_BITS 64
|
||||
# define SCM_C_BVEC_OFFSET_SHIFT 6
|
||||
# define SCM_C_BVEC_POS_MASK 63
|
||||
# define SCM_CELL_SIZE_SHIFT 4
|
||||
# define SCM_SIZEOF_LONG SIZEOF_LONG
|
||||
#else
|
||||
# define SCM_C_BVEC_LIMB_BITS 32
|
||||
# define SCM_C_BVEC_LONG_BITS 32
|
||||
# define SCM_SIZEOF_LONG SIZEOF_LONG
|
||||
# define SCM_C_BVEC_OFFSET_SHIFT 5
|
||||
# define SCM_C_BVEC_POS_MASK 31
|
||||
# define SCM_CELL_SIZE_SHIFT 3
|
||||
|
|
@ -150,23 +149,12 @@ typedef unsigned long scm_t_c_bvec_limb;
|
|||
|
||||
#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
#define SCM_C_BVEC_CLR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
|
||||
#define SCM_C_BVEC_BITS2BYTES(bits) \
|
||||
(sizeof (scm_t_c_bvec_limb) * ((((bits) & SCM_C_BVEC_POS_MASK) ? 1L : 0L) + SCM_C_BVEC_OFFSET (bits)))
|
||||
|
||||
#define SCM_C_BVEC_SET_BYTES(bvec, bytes) (memset (bvec, 0xff, bytes))
|
||||
#define SCM_C_BVEC_SET_ALL_BITS(bvec, bits) SCM_C_BVEC_SET_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits))
|
||||
|
||||
#define SCM_C_BVEC_CLR_BYTES(bvec, bytes) (memset (bvec, 0, bytes))
|
||||
#define SCM_C_BVEC_CLR_ALL_BITS(bvec, bits) SCM_C_BVEC_CLR_BYTES (bvec, SCM_C_BVEC_BITS2BYTES (bits))
|
||||
#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
|
||||
|
||||
/* testing and changing GC marks */
|
||||
|
||||
#define SCM_GCMARKP(x) SCM_GC_CELL_GET_BIT (x)
|
||||
#define SCM_SETGCMARK(x) SCM_GC_CELL_SET_BIT (x)
|
||||
#define SCM_CLRGCMARK(x) SCM_GC_CELL_CLR_BIT (x)
|
||||
|
||||
#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
|
||||
#define SCM_SET_GC_MARK(x) SCM_GC_CELL_SET_BIT (x)
|
||||
#define SCM_CLEAR_GC_MARK(x) SCM_GC_CELL_CLEAR_BIT (x)
|
||||
|
||||
/* Low level cell data accessing macros. These macros should only be used
|
||||
* from within code related to garbage collection issues, since they will
|
||||
|
|
@ -181,7 +169,7 @@ typedef unsigned long scm_t_c_bvec_limb;
|
|||
#define SCM_GC_SET_CELL_WORD(x, n, v) \
|
||||
(((scm_t_bits *) SCM2PTR (x)) [n] = (scm_t_bits) (v))
|
||||
#define SCM_GC_SET_CELL_OBJECT(x, n, v) \
|
||||
(((scm_t_bits *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
|
||||
(((scm_t_bits *) SCM2PTR (x)) [n] = SCM_UNPACK (v))
|
||||
#define SCM_GC_CELL_TYPE(x) SCM_GC_CELL_WORD (x, 0)
|
||||
|
||||
|
||||
|
|
@ -235,8 +223,14 @@ typedef unsigned long scm_t_c_bvec_limb;
|
|||
* the freelist. Due to this structure, freelist cells are not cons cells
|
||||
* and thus may not be accessed using SCM_CAR and SCM_CDR. */
|
||||
|
||||
#define SCM_FREE_CELL_P(x) \
|
||||
(!SCM_IMP (x) && (SCM_GC_CELL_TYPE (x) == scm_tc_free_cell))
|
||||
/*
|
||||
SCM_FREECELL_P removed ; the semantics are ambiguous with lazy
|
||||
sweeping. Could mean "this cell is no longer in use (will be swept)"
|
||||
or "this cell has just been swept, and is not yet in use".
|
||||
*/
|
||||
|
||||
#define SCM_FREECELL_P this_macro_has_been_removed_see_gc_header_file
|
||||
|
||||
#define SCM_FREE_CELL_CDR(x) \
|
||||
(SCM_GC_CELL_OBJECT ((x), 1))
|
||||
#define SCM_SET_FREE_CELL_CDR(x, v) \
|
||||
|
|
@ -248,49 +242,54 @@ typedef unsigned long scm_t_c_bvec_limb;
|
|||
#define SCM_CDRLOC(x) ((SCM *) SCM_CELL_WORD_LOC ((x), 1))
|
||||
|
||||
|
||||
/* SCM_PTR_LT and friends define how to compare two SCM_CELLPTRs (which may
|
||||
* point to cells in different heap segments).
|
||||
*/
|
||||
#define SCM_PTR_LT(x, y) ((x) < (y))
|
||||
#define SCM_PTR_GT(x, y) (SCM_PTR_LT (y, x))
|
||||
#define SCM_PTR_LE(x, y) (!SCM_PTR_GT (x, y))
|
||||
#define SCM_PTR_GE(x, y) (!SCM_PTR_LT (x, y))
|
||||
|
||||
|
||||
#define SCM_MARKEDP SCM_GCMARKP
|
||||
#define SCM_NMARKEDP(x) (!SCM_MARKEDP (x))
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
SCM_API unsigned int scm_debug_cell_accesses_p;
|
||||
#endif
|
||||
|
||||
SCM_API struct scm_t_heap_seg_data *scm_heap_table;
|
||||
SCM_API size_t scm_n_heap_segs;
|
||||
SCM_API int scm_block_gc;
|
||||
SCM_API int scm_gc_heap_lock;
|
||||
SCM_API unsigned int scm_gc_running_p;
|
||||
|
||||
|
||||
#if (SCM_ENABLE_DEPRECATED == 1)
|
||||
SCM_API size_t scm_default_init_heap_size_1;
|
||||
SCM_API int scm_default_min_yield_1;
|
||||
SCM_API size_t scm_default_init_heap_size_2;
|
||||
SCM_API int scm_default_min_yield_2;
|
||||
SCM_API size_t scm_default_max_segment_size;
|
||||
#else
|
||||
#define scm_default_init_heap_size_1 deprecated
|
||||
#define scm_default_min_yield_1 deprecated
|
||||
#define scm_default_init_heap_size_2 deprecated
|
||||
#define scm_default_min_yield_2 deprecated
|
||||
#define scm_default_max_segment_size deprecated
|
||||
#endif
|
||||
|
||||
|
||||
SCM_API size_t scm_max_segment_size;
|
||||
SCM_API SCM_CELLPTR scm_heap_org;
|
||||
SCM_API SCM scm_freelist;
|
||||
SCM_API struct scm_t_freelist scm_master_freelist;
|
||||
SCM_API SCM scm_freelist2;
|
||||
SCM_API struct scm_t_freelist scm_master_freelist2;
|
||||
|
||||
/*
|
||||
Deprecated scm_freelist, scm_master_freelist.
|
||||
No warning; this is not a user serviceable part.
|
||||
*/
|
||||
SCM_API SCM scm_i_freelist;
|
||||
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
|
||||
SCM_API SCM scm_i_freelist2;
|
||||
SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
|
||||
|
||||
SCM_API unsigned long scm_gc_cells_swept;
|
||||
SCM_API unsigned long scm_gc_cells_collected;
|
||||
SCM_API unsigned long scm_gc_cells_collected;
|
||||
SCM_API unsigned long scm_gc_yield;
|
||||
SCM_API unsigned long scm_gc_malloc_collected;
|
||||
SCM_API unsigned long scm_gc_ports_collected;
|
||||
SCM_API unsigned long scm_cells_allocated;
|
||||
SCM_API unsigned long scm_mallocated;
|
||||
SCM_API unsigned long scm_mtrigger;
|
||||
|
||||
|
||||
|
||||
SCM_API SCM scm_after_gc_hook;
|
||||
|
||||
SCM_API scm_t_c_hook scm_before_gc_c_hook;
|
||||
|
|
@ -300,32 +299,32 @@ SCM_API scm_t_c_hook scm_after_sweep_c_hook;
|
|||
SCM_API scm_t_c_hook scm_after_gc_c_hook;
|
||||
|
||||
#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
|
||||
SCM_API SCM scm_map_free_list (void);
|
||||
SCM_API SCM scm_free_list_length (void);
|
||||
#endif
|
||||
#ifdef GUILE_DEBUG_FREELIST
|
||||
SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
|
||||
#define scm_map_free_list deprecated
|
||||
#define scm_free_list_length deprecated
|
||||
#endif
|
||||
|
||||
#if (SCM_ENABLE_DEPRECATED == 1) && defined (GUILE_DEBUG_FREELIST)
|
||||
SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
|
||||
#endif
|
||||
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
SCM_API void scm_assert_cell_valid (SCM);
|
||||
SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);
|
||||
#endif
|
||||
|
||||
SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);
|
||||
|
||||
|
||||
SCM_API SCM scm_object_address (SCM obj);
|
||||
SCM_API SCM scm_gc_stats (void);
|
||||
SCM_API SCM scm_gc (void);
|
||||
SCM_API void scm_gc_for_alloc (struct scm_t_freelist *freelist);
|
||||
SCM_API SCM scm_gc_for_newcell (struct scm_t_freelist *master, SCM *freelist);
|
||||
#if 0
|
||||
SCM_API void scm_alloc_cluster (struct scm_t_freelist *master);
|
||||
#endif
|
||||
SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist);
|
||||
SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist);
|
||||
SCM_API void scm_igc (const char *what);
|
||||
SCM_API void scm_gc_mark (SCM p);
|
||||
SCM_API void scm_gc_mark_dependencies (SCM p);
|
||||
SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n);
|
||||
SCM_API int scm_cellp (SCM value);
|
||||
SCM_API int scm_in_heap_p (SCM value);
|
||||
SCM_API void scm_gc_sweep (void);
|
||||
|
||||
SCM_API void *scm_malloc (size_t size);
|
||||
|
|
|
|||
|
|
@ -142,14 +142,14 @@ static void
|
|||
unmark_port (SCM port)
|
||||
{
|
||||
SCM stream, string;
|
||||
port_mark_p = SCM_GCMARKP (port);
|
||||
SCM_CLRGCMARK (port);
|
||||
port_mark_p = SCM_GC_MARK_P (port);
|
||||
SCM_CLEAR_GC_MARK (port);
|
||||
stream = SCM_PACK (SCM_STREAM (port));
|
||||
stream_mark_p = SCM_GCMARKP (stream);
|
||||
SCM_CLRGCMARK (stream);
|
||||
stream_mark_p = SCM_GC_MARK_P (stream);
|
||||
SCM_CLEAR_GC_MARK (stream);
|
||||
string = SCM_CDR (stream);
|
||||
string_mark_p = SCM_GCMARKP (string);
|
||||
SCM_CLRGCMARK (string);
|
||||
string_mark_p = SCM_GC_MARK_P (string);
|
||||
SCM_CLEAR_GC_MARK (string);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -158,16 +158,19 @@ remark_port (SCM port)
|
|||
{
|
||||
SCM stream = SCM_PACK (SCM_STREAM (port));
|
||||
SCM string = SCM_CDR (stream);
|
||||
if (string_mark_p) SCM_SETGCMARK (string);
|
||||
if (stream_mark_p) SCM_SETGCMARK (stream);
|
||||
if (port_mark_p) SCM_SETGCMARK (port);
|
||||
if (string_mark_p)
|
||||
SCM_SET_GC_MARK (string);
|
||||
if (stream_mark_p)
|
||||
SCM_SET_GC_MARK (stream);
|
||||
if (port_mark_p)
|
||||
SCM_SET_GC_MARK (port);
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
gdb_maybe_valid_type_p (SCM value)
|
||||
{
|
||||
return SCM_IMP (value) || scm_cellp (value);
|
||||
return SCM_IMP (value) || scm_in_heap_p (value);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -211,8 +214,8 @@ gdb_read (char *str)
|
|||
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
|
||||
scm_seek (gdb_input_port, SCM_INUM0, SCM_MAKINUM (SEEK_SET));
|
||||
/* Read one object */
|
||||
tok_buf_mark_p = SCM_GCMARKP (tok_buf);
|
||||
SCM_CLRGCMARK (tok_buf);
|
||||
tok_buf_mark_p = SCM_GC_MARK_P (tok_buf);
|
||||
SCM_CLEAR_GC_MARK (tok_buf);
|
||||
ans = scm_lreadr (&tok_buf, gdb_input_port, &ans);
|
||||
if (SCM_GC_P)
|
||||
{
|
||||
|
|
@ -229,7 +232,7 @@ gdb_read (char *str)
|
|||
scm_permanent_object (ans);
|
||||
exit:
|
||||
if (tok_buf_mark_p)
|
||||
SCM_SETGCMARK (tok_buf);
|
||||
SCM_SET_GC_MARK (tok_buf);
|
||||
remark_port (gdb_input_port);
|
||||
SCM_END_FOREIGN_BLOCK;
|
||||
return status;
|
||||
|
|
|
|||
|
|
@ -447,19 +447,19 @@ mark_dependencies_in_tconc (t_tconc *tc)
|
|||
SCM obj = SCM_CAR (pair);
|
||||
next_pair = SCM_CDR (pair);
|
||||
|
||||
if (! SCM_MARKEDP (obj))
|
||||
if (! SCM_GC_MARK_P (obj))
|
||||
{
|
||||
/* a candidate for finalizing */
|
||||
scm_gc_mark_dependencies (obj);
|
||||
|
||||
if (SCM_MARKEDP (obj))
|
||||
if (SCM_GC_MARK_P (obj))
|
||||
{
|
||||
/* uh oh. a cycle. transfer this object (the
|
||||
spine cell, to be exact) to
|
||||
self_centered_zombies, so we'll be able to
|
||||
complain about it later. */
|
||||
*prev_ptr = next_pair;
|
||||
SCM_SETGCMARK (pair);
|
||||
SCM_SET_GC_MARK (pair);
|
||||
SCM_SETCDR (pair, self_centered_zombies);
|
||||
self_centered_zombies = pair;
|
||||
}
|
||||
|
|
@ -494,7 +494,7 @@ mark_and_zombify (t_guardian *g)
|
|||
{
|
||||
SCM next_pair = SCM_CDR (pair);
|
||||
|
||||
if (!SCM_MARKEDP (SCM_CAR (pair)))
|
||||
if (!SCM_GC_MARK_P (SCM_CAR (pair)))
|
||||
{
|
||||
/* got you, zombie! */
|
||||
|
||||
|
|
@ -504,7 +504,7 @@ mark_and_zombify (t_guardian *g)
|
|||
if (GREEDY_P (g))
|
||||
/* if the guardian is greedy, mark this zombie now. this
|
||||
way it won't be zombified again this time around. */
|
||||
SCM_SETGCMARK (SCM_CAR (pair));
|
||||
SCM_SET_GC_MARK (SCM_CAR (pair));
|
||||
|
||||
/* into the zombie list! */
|
||||
TCONC_IN (g->zombies, SCM_CAR (pair), pair);
|
||||
|
|
@ -519,7 +519,7 @@ mark_and_zombify (t_guardian *g)
|
|||
don't care about objects pointed to by the list cars, since we
|
||||
know they are already marked). */
|
||||
for (pair = g->live.head; !SCM_NULLP (pair); pair = SCM_CDR (pair))
|
||||
SCM_SETGCMARK (pair);
|
||||
SCM_SET_GC_MARK (pair);
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -453,7 +453,9 @@ scm_init_guile_1 (SCM_STACKITEM *base)
|
|||
#ifdef GUILE_DEBUG_MALLOC
|
||||
scm_debug_malloc_prehistory ();
|
||||
#endif
|
||||
scm_init_storage (); /* requires smob_prehistory */
|
||||
if (scm_init_storage ()) /* requires smob_prehistory */
|
||||
abort ();
|
||||
|
||||
scm_struct_prehistory (); /* requires storage */
|
||||
scm_symbols_prehistory (); /* requires storage */
|
||||
scm_weaks_prehistory (); /* requires storage */
|
||||
|
|
|
|||
|
|
@ -41,9 +41,10 @@
|
|||
|
||||
#include "libguile/scmconfig.h"
|
||||
|
||||
#ifndef HAVE_INLINE
|
||||
|
||||
#define HAVE_INLINE
|
||||
#define EXTERN_INLINE
|
||||
#undef SCM_INLINE_H
|
||||
|
||||
#include "libguile/inline.h"
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -49,35 +49,73 @@
|
|||
"inline.c".
|
||||
*/
|
||||
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
#include <stdio.h>
|
||||
#endif
|
||||
|
||||
#include "libguile/pairs.h"
|
||||
#include "libguile/gc.h"
|
||||
|
||||
|
||||
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
|
||||
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
||||
scm_t_bits ccr, scm_t_bits cdr);
|
||||
|
||||
#ifdef HAVE_INLINE
|
||||
|
||||
static inline SCM
|
||||
|
||||
|
||||
#ifndef EXTERN_INLINE
|
||||
#define EXTERN_INLINE extern inline
|
||||
#endif
|
||||
|
||||
extern unsigned scm_newcell2_count;
|
||||
extern unsigned scm_newcell_count;
|
||||
|
||||
|
||||
EXTERN_INLINE
|
||||
SCM
|
||||
scm_cell (scm_t_bits car, scm_t_bits cdr)
|
||||
{
|
||||
SCM z;
|
||||
|
||||
#ifdef GUILE_DEBUG_FREELIST
|
||||
scm_newcell_count++;
|
||||
if (scm_debug_check_freelist)
|
||||
if (SCM_NULLP (scm_i_freelist))
|
||||
{
|
||||
scm_check_freelist (scm_freelist);
|
||||
scm_gc();
|
||||
}
|
||||
#endif
|
||||
|
||||
if (SCM_NULLP (scm_freelist))
|
||||
{
|
||||
z = scm_gc_for_newcell (&scm_master_freelist, &scm_freelist);
|
||||
z = scm_gc_for_newcell (&scm_i_master_freelist, &scm_i_freelist);
|
||||
}
|
||||
else
|
||||
{
|
||||
z = scm_freelist;
|
||||
scm_freelist = SCM_FREE_CELL_CDR (scm_freelist);
|
||||
z = scm_i_freelist;
|
||||
scm_i_freelist = SCM_FREE_CELL_CDR (scm_i_freelist);
|
||||
}
|
||||
|
||||
/*
|
||||
We update scm_cells_allocated from this function. If we don't
|
||||
update this explicitly, we will have to walk a freelist somewhere
|
||||
later on, which seems a lot more expensive.
|
||||
*/
|
||||
scm_cells_allocated += 1;
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (scm_debug_cell_accesses_p)
|
||||
{
|
||||
if (SCM_GC_MARK_P (z))
|
||||
{
|
||||
fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
|
||||
abort();
|
||||
}
|
||||
else if (SCM_GC_CELL_TYPE(z) != scm_tc_free_cell)
|
||||
{
|
||||
fprintf(stderr, "cell from freelist is not a free cell.\n");
|
||||
abort();
|
||||
}
|
||||
|
||||
SCM_SET_GC_MARK (z);
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
/* Initialize the type slot last so that the cell is ignored by the
|
||||
GC until it is completely initialized. This is only relevant
|
||||
when the GC can actually run during this code, which it can't for
|
||||
|
|
@ -98,34 +136,31 @@ scm_cell (scm_t_bits car, scm_t_bits cdr)
|
|||
#endif
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
return z;
|
||||
}
|
||||
|
||||
static inline SCM
|
||||
EXTERN_INLINE
|
||||
SCM
|
||||
scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
||||
scm_t_bits ccr, scm_t_bits cdr)
|
||||
{
|
||||
SCM z;
|
||||
|
||||
#ifdef GUILE_DEBUG_FREELIST
|
||||
scm_newcell2_count++;
|
||||
if (scm_debug_check_freelist)
|
||||
{
|
||||
scm_check_freelist (scm_freelist2);
|
||||
scm_gc();
|
||||
}
|
||||
#endif
|
||||
|
||||
if (SCM_NULLP (scm_freelist2))
|
||||
if (SCM_NULLP (scm_i_freelist2))
|
||||
{
|
||||
z = scm_gc_for_newcell (&scm_master_freelist2, &scm_freelist2);
|
||||
z = scm_gc_for_newcell (&scm_i_master_freelist2, &scm_i_freelist2);
|
||||
}
|
||||
else
|
||||
{
|
||||
z = scm_freelist2;
|
||||
scm_freelist2 = SCM_FREE_CELL_CDR (scm_freelist2);
|
||||
z = scm_i_freelist2;
|
||||
scm_i_freelist2 = SCM_FREE_CELL_CDR (scm_i_freelist2);
|
||||
}
|
||||
|
||||
scm_cells_allocated += 2;
|
||||
|
||||
/* Initialize the type slot last so that the cell is ignored by the
|
||||
GC until it is completely initialized. This is only relevant
|
||||
when the GC can actually run during this code, which it can't for
|
||||
|
|
@ -148,15 +183,23 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
|||
#endif
|
||||
#endif
|
||||
|
||||
|
||||
#if (SCM_DEBUG_CELL_ACCESSES == 1)
|
||||
if (scm_debug_cell_accesses_p)
|
||||
{
|
||||
if (SCM_GC_MARK_P (z))
|
||||
{
|
||||
fprintf(stderr,
|
||||
"scm_double_cell tried to allocate a marked cell.\n");
|
||||
abort();
|
||||
}
|
||||
|
||||
SCM_SET_GC_MARK (z);
|
||||
}
|
||||
#endif
|
||||
|
||||
return z;
|
||||
}
|
||||
|
||||
#else /* !HAVE_INLINE */
|
||||
|
||||
SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
|
||||
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
|
||||
scm_t_bits ccr, scm_t_bits cdr);
|
||||
|
||||
#endif
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -2288,6 +2288,12 @@ big2str (SCM b, unsigned int radix)
|
|||
SCM_BIGDIG radpow = 1, radmod = 0;
|
||||
SCM ss = scm_allocate_string (j);
|
||||
char *s = SCM_STRING_CHARS (ss), c;
|
||||
|
||||
if (i == 0)
|
||||
{
|
||||
return scm_makfrom0str ("0");
|
||||
}
|
||||
|
||||
while ((long) radpow * radix < SCM_BIGRAD)
|
||||
{
|
||||
radpow *= radix;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@
|
|||
|
||||
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
|
||||
|
||||
#include "libguile/ports.h"
|
||||
/~#include "libguile/ports.h"
|
||||
#include "libguile/strings.h"
|
||||
|
||||
void scm_error_pair_access (SCM non_pair)
|
||||
|
|
|
|||
|
|
@ -739,7 +739,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
|
|||
{
|
||||
scm_puts ("#<unknown-", port);
|
||||
scm_puts (hdr, port);
|
||||
if (scm_cellp (ptr))
|
||||
if (scm_in_heap_p (ptr))
|
||||
{
|
||||
scm_puts (" (0x", port);
|
||||
scm_intprint (SCM_CELL_WORD_0 (ptr), 16, port);
|
||||
|
|
|
|||
|
|
@ -139,7 +139,7 @@ scm_mark_subr_table ()
|
|||
long i;
|
||||
for (i = 0; i < scm_subr_table_size; ++i)
|
||||
{
|
||||
SCM_SETGCMARK (scm_subr_table[i].name);
|
||||
SCM_SET_GC_MARK (scm_subr_table[i].name);
|
||||
if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
|
||||
scm_gc_mark (*scm_subr_table[i].generic);
|
||||
if (SCM_NIMP (scm_subr_table[i].properties))
|
||||
|
|
|
|||
|
|
@ -270,14 +270,13 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
|
|||
/* The match vector must include a cell for the string that was matched,
|
||||
so add 1. */
|
||||
mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED);
|
||||
SCM_VELTS(mvec)[0] = str;
|
||||
SCM_VECTOR_SET(mvec,0, str);
|
||||
for (i = 0; i < nmatches; ++i)
|
||||
if (matches[i].rm_so == -1)
|
||||
SCM_VELTS(mvec)[i+1] = scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1));
|
||||
SCM_VECTOR_SET(mvec,i+1, scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1)));
|
||||
else
|
||||
SCM_VELTS(mvec)[i+1]
|
||||
= scm_cons (scm_long2num (matches[i].rm_so + offset),
|
||||
scm_long2num (matches[i].rm_eo + offset));
|
||||
SCM_VECTOR_SET(mvec,i+1,scm_cons (scm_long2num (matches[i].rm_so + offset),
|
||||
scm_long2num (matches[i].rm_eo + offset)));
|
||||
}
|
||||
free (matches);
|
||||
SCM_ALLOW_INTS;
|
||||
|
|
|
|||
|
|
@ -378,7 +378,7 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
|
|||
{
|
||||
SCM vtable = SCM_STRUCT_VTABLE (chain);
|
||||
if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
|
||||
SCM_SETGCMARK (vtable);
|
||||
SCM_SET_GC_MARK (vtable);
|
||||
chain = SCM_STRUCT_GC_CHAIN (chain);
|
||||
}
|
||||
/* Free unmarked structs. */
|
||||
|
|
@ -388,9 +388,9 @@ scm_free_structs (void *dummy1 SCM_UNUSED,
|
|||
{
|
||||
SCM obj = chain;
|
||||
chain = SCM_STRUCT_GC_CHAIN (chain);
|
||||
if (SCM_GCMARKP (obj))
|
||||
if (SCM_GC_MARK_P (obj))
|
||||
{
|
||||
SCM_CLRGCMARK (obj);
|
||||
SCM_CLEAR_GC_MARK (obj);
|
||||
SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
|
||||
newchain = obj;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -120,19 +120,14 @@ scm_mem2symbol (const char *name, size_t len)
|
|||
|
||||
{
|
||||
/* The symbol was not found - create it. */
|
||||
|
||||
SCM symbol;
|
||||
SCM cell;
|
||||
SCM slot;
|
||||
|
||||
symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
|
||||
SCM symbol = scm_double_cell (SCM_MAKE_SYMBOL_TAG (len),
|
||||
(scm_t_bits) scm_gc_strndup (name, len,
|
||||
"symbol"),
|
||||
raw_hash,
|
||||
SCM_UNPACK (scm_cons (SCM_BOOL_F, SCM_EOL)));
|
||||
|
||||
slot = SCM_VELTS (symbols) [hash];
|
||||
cell = scm_cons (symbol, SCM_UNDEFINED);
|
||||
SCM slot = SCM_VELTS (symbols) [hash];
|
||||
SCM cell = scm_cons (symbol, SCM_UNDEFINED);
|
||||
SCM_VECTOR_SET (symbols, hash, scm_cons (cell, slot));
|
||||
|
||||
return symbol;
|
||||
|
|
|
|||
|
|
@ -278,11 +278,11 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
|
|||
|
||||
alist = ptr[j];
|
||||
while ( SCM_CONSP (alist)
|
||||
&& !SCM_GCMARKP (alist)
|
||||
&& !SCM_GC_MARK_P (alist)
|
||||
&& SCM_CONSP (SCM_CAR (alist)))
|
||||
{
|
||||
SCM_SETGCMARK (alist);
|
||||
SCM_SETGCMARK (SCM_CAR (alist));
|
||||
SCM_SET_GC_MARK (alist);
|
||||
SCM_SET_GC_MARK (SCM_CAR (alist));
|
||||
alist = SCM_CDR (alist);
|
||||
}
|
||||
}
|
||||
|
|
@ -292,6 +292,7 @@ scm_mark_weak_vector_spines (void *dummy1 SCM_UNUSED,
|
|||
return 0;
|
||||
}
|
||||
|
||||
#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
|
||||
|
||||
static void *
|
||||
scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
|
||||
|
|
@ -308,7 +309,7 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
|
|||
ptr = SCM_GC_WRITABLE_VELTS (w);
|
||||
n = SCM_VECTOR_LENGTH (w);
|
||||
for (j = 0; j < n; ++j)
|
||||
if (SCM_FREE_CELL_P (ptr[j]))
|
||||
if (UNMARKED_CELL_P (ptr[j]))
|
||||
ptr[j] = SCM_BOOL_F;
|
||||
}
|
||||
else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
|
||||
|
|
@ -329,16 +330,16 @@ scm_scan_weak_vectors (void *dummy1 SCM_UNUSED,
|
|||
fixup = ptr + j;
|
||||
alist = *fixup;
|
||||
|
||||
while ( SCM_CONSP (alist)
|
||||
&& SCM_CONSP (SCM_CAR (alist)))
|
||||
while (SCM_CONSP (alist)
|
||||
&& SCM_CONSP (SCM_CAR (alist)))
|
||||
{
|
||||
SCM key;
|
||||
SCM value;
|
||||
|
||||
key = SCM_CAAR (alist);
|
||||
value = SCM_CDAR (alist);
|
||||
if ( (weak_keys && SCM_FREE_CELL_P (key))
|
||||
|| (weak_values && SCM_FREE_CELL_P (value)))
|
||||
if ( (weak_keys && UNMARKED_CELL_P (key))
|
||||
|| (weak_values && UNMARKED_CELL_P (value)))
|
||||
{
|
||||
*fixup = SCM_CDR (alist);
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue