mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 13:00:34 +02:00
Code Activity

* tags.h: (SCM_DOUBLE_CELLP, SCM_NDOUBLE_CELLP): new macros.

Browse source 
* gc.h: (typedef struct scm_freelist_t) remove from here.

* gc.c: (CELL_UP, CELL_DN) make these macros take additional
parameter (the span).
(CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK) new macros.
(typedef struct scm_freelist_t) move here from gc.h, it had no
business being externally visible.
(typedef struct scm_heap_seg_data_t) renamed from
scm_heap_seg_data, to be style-compliant.
(scm_mark_locations) if the possible pointer points to a
multy-cell, check that it's properly aligned.
(init_heap_seg) alighn multy-cells properly, work with the
assumption that the segment size divides cleanly by cluster size
(so that there's no spill).
(round_to_cluster_size) new function.
(alloc_some_heap, make_initial_segment) use round_to_cluster_size
to satisfy the new init_heap_seg invariant.
This commit is contained in:
Michael Livshin 2000-03-18 11:09:41 +00:00
parent 28b3236d36
commit a00c95d9c6
4 changed files with 221 additions and 175 deletions
Download patch file Download diff file Expand all files Collapse all files

90
libguile/ChangeLog
View file

@ -1,3 +1,25 @@
2000-03-18 Michael Livshin <mlivshin@bigfoot.com>
* tags.h: (SCM_DOUBLE_CELLP, SCM_NDOUBLE_CELLP): new macros.
* gc.h: (typedef struct scm_freelist_t) remove from here.
* gc.c: (CELL_UP, CELL_DN) make these macros take additional
parameter (the span).
(CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK) new macros.
(typedef struct scm_freelist_t) move here from gc.h, it had no
business being externally visible.
(typedef struct scm_heap_seg_data_t) renamed from
scm_heap_seg_data, to be style-compliant.
(scm_mark_locations) if the possible pointer points to a
multy-cell, check that it's properly aligned.
(init_heap_seg) alighn multy-cells properly, work with the
assumption that the segment size divides cleanly by cluster size
(so that there's no spill).
(round_to_cluster_size) new function.
(alloc_some_heap, make_initial_segment) use round_to_cluster_size
to satisfy the new init_heap_seg invariant.
2000-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* _scm.h: Don't include async.h everywhere...
@ -69,13 +91,13 @@
GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2
2000-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* __scm.h (GC_FREE_SEGMENTS): Disable this until we have made
freeing of segment work with the new GC scheme. (Thanks to
Michael Livshin.) Oops, also happened to make GUILE_NEW_GC_SCHEME
the default, but I'll let this change stay in CVS Guile since this
code is not expected to contain serious bugs.
2000-03-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* gc.c, gc.h (scm_map_free_list): Define also if GUILE_DEBUG is
@ -98,7 +120,7 @@ Wed Mar 15 08:27:04 2000 Greg J. Badros <gjb@cs.washington.edu>
Wed Mar 15 08:24:58 2000 Greg J. Badros <gjb@cs.washington.edu>
* Makefile.am: Separate out DOT_X_FILES and DOT_DOC_FILES, and
generate the latter from the concrete listing of the former. Then
generate the latter from the concrete listing of the former. Then
make guile-procedures.txt depend on DOT_DOC_FILES instead of
*.doc, so that rebuilding it works.
@ -130,7 +152,7 @@ Wed Mar 15 08:12:14 2000 Greg J. Badros <gjb@cs.washington.edu>
The following change to init.c is only enabled if Guile was
configured with --enable-guile-debug.
* init.c (scm_i_getenv_int): New function.
(scm_boot_guile_1): Use the environment variables
GUILE_INIT_HEAP_SIZE, GUILE_INIT_HEAP_SIZE2 to select heap size if
@ -264,7 +286,7 @@ Wed Mar 15 08:12:14 2000 Greg J. Badros <gjb@cs.washington.edu>
* async.c, async.h: made async representation a double cell.
* dynl.c: made dynamic_obj representation a double cell.
2000-03-13 Gary Houston <ghouston@arglist.com>
* ports.c (flush_void_port): renamed to flush_port_default.
@ -294,7 +316,7 @@ Wed Mar 15 08:12:14 2000 Greg J. Badros <gjb@cs.washington.edu>
that we can't use autoconf for this. Autoconf itself relies on
the existence of `sed' somewhere on your path.) (Thanks to Dirk
Herrman.)
2000-03-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* Makefile.am (libguile_la_SOURCES): Moved iselect.c here from
@ -364,10 +386,10 @@ Sun Mar 12 13:26:30 2000 Greg J. Badros <gjb@cs.washington.edu>
* struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes.
2000-03-12 Marius Vollmer <mvo@zagadka.ping.de>
* init.c (scm_standard_stream_to_port): Check whether the file
descriptor is valid and substitute "/dev/null" when not.
2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* coop-defs.h (struct timespec): Conditionally defined.
@ -383,14 +405,14 @@ Sun Mar 12 13:26:30 2000 Greg J. Badros <gjb@cs.washington.edu>
code. It moves things to better places, makes arguments more
consistent with the POSIX API (which is used in GNOME's glib), and
adds new functionality.
* readline.c (scm_init_readline): Added new arg to scm_init_mutex.
* coop-defs.h (scm_mutex_trylock): New macro: alias for
coop_mutex_trylock.
(scm_cond_init): Changed definition to
coop_new_condition_variable_init.
* coop.c: #include <errno.h>
(coop_timeout_qinsert): Moved here from iselect.c
(coop_new_mutex_init, coop_new_condition_variable_init): New
@ -434,7 +456,7 @@ Sun Mar 12 13:26:30 2000 Greg J. Badros <gjb@cs.washington.edu>
Thu Mar 9 11:33:25 2000 Greg J. Badros <gjb@cs.washington.edu>
* vectors.h (SCM_VELTS_AS_STACKITEMS): Added this macro to help in
* vectors.h (SCM_VELTS_AS_STACKITEMS): Added this macro to help in
eliminating some warnings.
* unif.c, strports.c, print.c, options.c: Fix some warnings on
@ -450,7 +472,7 @@ Thu Mar 9 11:33:25 2000 Greg J. Badros <gjb@cs.washington.edu>
storing tags and immediates (now a long int). Introduced
SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious
code in the process: arbiter.c (use macros), unif.c (scm_array_p),
Wed Mar 8 10:15:59 2000 Greg J. Badros <gjb@cs.washington.edu>
* numbers.c: Use SCM_VALIDATE_LONG_COPY, and longs, not ints, in
@ -493,7 +515,7 @@ Thu Mar 2 15:13:25 2000 Greg J. Badros <gjb@cs.washington.edu>
Thu Mar 2 12:38:30 2000 Greg J. Badros <gjb@cs.washington.edu>
* list.c: Moved append docs to append! Thanks Dirk Hermann. Also,
* list.c: Moved append docs to append! Thanks Dirk Hermann. Also,
added append docs from R4RS.
* strings.c: Docstring typo fix, + eliminate unneeded IMP tests.
@ -501,7 +523,7 @@ Thu Mar 2 12:38:30 2000 Greg J. Badros <gjb@cs.washington.edu>
* chars.h: Provide SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR and
deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann!
* *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout.
Drop use of SCM_P for function prototypes... assume an ANSI C
compiler. Thanks Dirk Hermann!
@ -516,7 +538,7 @@ Sat Feb 19 12:20:12 2000 Greg J. Badros <gjb@cs.washington.edu>
Sun Feb 13 19:11:42 2000 Greg J. Badros <gjb@cs.washington.edu>
* arbiters.c, eq.c, gc.c, guardians.c, list.c, ports.c, print.c,
regex-posix.c, scmsigs.c, stime.c, strings.c, variable.c, stime.c,
regex-posix.c, scmsigs.c, stime.c, strings.c, variable.c, stime.c,
strings.c, variable.c: Added lots of documentation, cleaned up
some existing documentation. Occasionally changed formal params
to match docs. Also folded an #ifdef into the inners of a
@ -576,7 +598,7 @@ Sun Feb 6 20:26:21 2000 Greg J. Badros <gjb@cs.washington.edu>
* strings.h: don't use SCM_P. don't include <string.h>.
* error.c, gh_data.c, ports.c, script.c, strop.c: include <string.h>.
* strings.c (scm_string_ref): make the 2nd argument compulsory.
previously it defaulted to zero for no good reason that I can see.
use a local variable for SCM_INUM (k). replace
@ -602,7 +624,7 @@ Sun Feb 6 20:26:21 2000 Greg J. Badros <gjb@cs.washington.edu>
"select" tests port buffers for the ability to provide input
or accept output. Previously only the underlying file descriptors
were checked. Rewrote the docstring.
Thu Jan 27 10:14:25 2000 Greg J. Badros <gjb@cs.washington.edu>
* vectors.c, symbols.c, strorder.c: Documentation cut and pasted
@ -624,13 +646,13 @@ Wed Jan 26 17:33:52 2000 Greg J. Badros <gjb@cs.washington.edu>
Wed Jan 26 10:02:11 2000 Greg J. Badros <gjb@cs.washington.edu>
* tag.c: Added doc for `tag', but mark as deprecated since Mikael
* tag.c: Added doc for `tag', but mark as deprecated since Mikael
suggests removing tag.c altogether (and using a new `class-of'
instead).
* strings.c: Added documentation from Gregg A. Reynolds. Edited
a bit by me to use FOO instead of @var{foo} and to have the
summary come before preconditions on input. Also dropped trailing
summary come before preconditions on input. Also dropped trailing
(rnrs) note.
* gsubr.c: Do not use SCM_DEFINE for `gsubr-apply'. Register the
@ -652,7 +674,7 @@ Tue Jan 25 17:15:47 2000 Greg J. Badros <gjb@cs.washington.edu>
* eq.c: Added docs for eq?, eqv? equal? abridged from R4RS.
* boolean.c: Added docs for `not', `boolean?' (by hand).
Tue Jan 25 13:28:56 2000 Greg J. Badros <gjb@cs.washington.edu>
* random.c: Added documentation, from SLIB page:
@ -666,7 +688,7 @@ Mon Jan 24 17:50:20 2000 Greg J. Badros <gjb@cs.washington.edu>
2000-01-23 Gary Houston <ghouston@arglist.com>
* filesys.c (scm_chown): omit port/fdes support if HAVE_FCHOWN is
* filesys.c (scm_chown): omit port/fdes support if HAVE_FCHOWN is
not defined (thanks to Richard Y. Kim).
Thu Jan 20 13:00:38 2000 Greg J. Badros <gjb@cs.washington.edu>
@ -713,7 +735,7 @@ Tue Jan 18 13:21:08 2000 Mikael Djurfeldt <mdj@r11n07-s.pdc.kth.se>
stacks.c, stime.c, strings.c, strop.c, strports.c, struct.c,
symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c,
weaks.c: Converted docstrings to ANSI C format.
* filesys.c (scm_chmod), simpos.c (scm_system), version
(scm_version), vports (scm_make_soft_port): Escape " occuring
inside docstring.
@ -749,7 +771,7 @@ Tue Jan 11 18:24:18 2000 Greg J. Badros <gjb@cs.washington.edu>
* guile-doc-snarf.in: Use new $fullfilename for running
guile-func-name-check, and put "$fullfilename" and "$filename" in
quotes at uses to make sure re-splitting on whitespace does not
occur (so filenames w/ embedded whitespace would work okay, though
occur (so filenames w/ embedded whitespace would work okay, though
I sure hope we never have to deal with that! :-) ). Thanks to
Mikael for pointing out the source_dir != build_dir was broken.
@ -827,7 +849,7 @@ Tue Jan 11 13:44:07 2000 Greg J. Badros <gjb@cs.washington.edu>
* ramap.c: Fix #if 0'd out code to be syntactically acceptable to
guile-func-name-check.
* guile-doc-snarf.in: Run guile-func-name-check on the file before
* guile-doc-snarf.in: Run guile-func-name-check on the file before
doing the snarf.
Tue Jan 11 11:31:10 2000 Greg J. Badros <gjb@cs.washington.edu>
@ -852,7 +874,7 @@ Tue Jan 11 10:41:46 2000 Greg J. Badros <gjb@cs.washington.edu>
* print.h, print.c (scm_simple_format): Added `simple-format'
primitive. It's the old scm_display_error, with ARGS now a rest
parameter, and the destination first instead of last (and a couple
parameter, and the destination first instead of last (and a couple
new capabilities inspired by `format' -- #t as destination means
current-output-port, #f means return the formatted text as a
string.
@ -873,7 +895,7 @@ Tue Jan 11 10:41:46 2000 Greg J. Badros <gjb@cs.washington.edu>
* dynl.c: Use ANSI prototypes.
(sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen.
* scmconfig.h.in: Do not change, as it is automatically generated.
1999-07-25 Thomas Tanner <tanner@ffii.org>
* dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c: deleted
@ -910,12 +932,12 @@ Tue Jan 11 10:41:46 2000 Greg J. Badros <gjb@cs.washington.edu>
scm_lookupcar1: throw an error with key 'unbound-variable instead
of 'misc-error when an unbound variable is encountered.
* filesys.c (scm_mkdir, scm_rmdir, scm_getcwd, scm_select,
* filesys.c (scm_mkdir, scm_rmdir, scm_getcwd, scm_select,
scm_symlink, scm_readlink, scm_lstat),
posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp,
scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice,
scm_sync),
simpos.c (scm_system),
simpos.c (scm_system),
stime.c (scm_times, scm_strptime):
move the HAVE_XXX feature tests out of the procedure bodies.
don't use SCM_SYSMISSING.
@ -939,9 +961,9 @@ Fri Jan 7 15:50:46 2000 Greg J. Badros <gjb@cs.washington.edu>
* scm_validate.h (SCM_OUT_OF_RANGE): Use scm_out_of_range_pos to
report the position of the argument.
* error.h, error.c (scm_out_of_range_pos): Added this function to
* error.h, error.c (scm_out_of_range_pos): Added this function to
take extra "pos" argument, the position number of the errant
argument.
argument.
* debug.c: Use SCM_OUT_OF_RANGE instead of scm_out_of_range.
@ -980,7 +1002,7 @@ Thu Jan 6 11:22:53 2000 Greg J. Badros <gjb@cs.washington.edu>
Thu Jan 6 11:21:49 2000 Greg J. Badros <gjb@cs.washington.edu>
* alist.c: Do not report mismatch errors on some uses of `tmp' (do
* alist.c: Do not report mismatch errors on some uses of `tmp' (do
this by using SCM_ARG2 instead of `2' in the SCM_VALIDATE_CONS
macro call.
@ -1043,7 +1065,7 @@ Wed Jan 5 10:50:39 2000 Greg J. Badros <gjb@cs.washington.edu>
formal in the current argument snarfing check.
* snarf.h: Give new definition of SCM_ASSERT when in
snarfing mode to output a lexically-identifiable sequence that the
snarfing mode to output a lexically-identifiable sequence that the
guile-snarf.awk script uses to verify argument/position matching.
* ramap.c: Remove extraneous #undef FUNC_NAME.
@ -1051,7 +1073,7 @@ Wed Jan 5 10:50:39 2000 Greg J. Badros <gjb@cs.washington.edu>
Wed Jan 5 08:36:38 2000 Greg J. Badros <gjb@cs.washington.edu>
* guile-doc-snarf.awk.in: Removed -- guile-snarf.awk.in is the
current version of the same functionality; it writes the .x output
current version of the same functionality; it writes the .x output
to stdout instead of directly into the file.
Wed Jan 5 08:15:04 2000 Greg J. Badros <gjb@cs.washington.edu>
@ -1083,7 +1105,7 @@ Tue Jan 4 14:21:35 2000 Greg J. Badros <gjb@cs.washington.edu>
Mon Jan 3 08:30:02 2000 Greg Harvey <Greg.Harvey@thezone.net> (applied --01/03/00 gjb)
* gc.c (scm_debug_newcell): Added SCM_SETCAR of the newly
allocated cell.
allocated cell.
* pairs.h: Added a comment about the need for the SCM_SETCAR in
SCM_NEWCELL macro.

246
libguile/gc.c
View file

@ -1,15 +1,15 @@
/* 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
* 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,
@ -79,7 +79,7 @@
/* {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.
*
@ -95,7 +95,7 @@
* 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.
*
@ -103,13 +103,13 @@
* is needed.
*
* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
* trigger a GC.
* 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.]
* work around a oscillation that caused almost constant GC.]
*/
#define SCM_INIT_HEAP_SIZE_1 (40000L * sizeof (scm_cell))
@ -145,23 +145,58 @@
#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))
# define CELL_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
# define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&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))
# define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
# define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (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))
# define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
# define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
# endif /* UNICOS */
#endif /* PROT386 */
#define CLUSTER_SIZE_IN_BYTES(freelist) ((freelist)->cluster_size * (freelist)->span * sizeof(scm_cell))
#define ALIGNMENT_SLACK(freelist) (sizeof (scm_cell) * (freelist)->span - 1)
/* scm_freelists
*/
typedef struct scm_freelist_t {
/* collected cells */
SCM cells;
#ifdef GUILE_NEW_GC_SCHEME
/* number of cells left to collect before cluster is full */
unsigned int left_to_collect;
/* a list of freelists, each of size gc_trigger,
except the last one which may be shorter */
SCM clusters;
SCM *clustertail;
/* this is the number of cells in each cluster, including the spine cell */
int cluster_size;
/* set to grow the heap when we run out of clusters
*/
int grow_heap_p;
/* minimum number of objects allocated before GC is triggered
*/
int gc_trigger;
/* defines gc_trigger as percent of heap size
* 0 => constant trigger
*/
int gc_trigger_fraction;
#endif
/* number of cells per object on this list */
int span;
/* number of collected cells during last GC */
int collected;
/* total number of cells in heap segments
* belonging to this list.
*/
int heap_size;
} scm_freelist_t;
#ifdef GUILE_NEW_GC_SCHEME
SCM scm_freelist = SCM_EOL;
scm_freelist_t scm_master_freelist = {
@ -222,8 +257,7 @@ 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
typedef struct scm_heap_seg_data_t
{
/* lower and upper bounds of the segment */
SCM_CELLPTR bounds[2];
@ -240,7 +274,7 @@ struct scm_heap_seg_data
SEG_DATA, and mark the object iff the function returns non-zero.
At the moment, I don't think anyone uses this. */
int (*valid) ();
};
} scm_heap_seg_data_t;
@ -277,7 +311,7 @@ map_free_list (scm_freelist_t *master, SCM freelist)
{
int last_seg = -1, count = 0;
SCM f;
for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f))
{
int this_seg = which_seg (f);
@ -302,7 +336,7 @@ map_free_list (scm_freelist_t *freelist)
{
int last_seg = -1, count = 0;
SCM f;
for (f = freelist->cells; SCM_NIMP (f); f = SCM_CDR (f))
{
int this_seg = which_seg (f);
@ -323,7 +357,7 @@ map_free_list (scm_freelist_t *freelist)
}
#endif
SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
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.")
@ -409,7 +443,7 @@ free_list_lengths (char *title, scm_freelist_t *master, SCM freelist)
fprintf (stderr, "\ntotal %d objects\n\n", n);
}
SCM_DEFINE (scm_free_list_length, "free-list-length", 0, 0, 0,
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.")
@ -468,7 +502,7 @@ scm_check_freelist (scm_freelist_t *freelist)
static int scm_debug_check_freelist = 0;
SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
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"
@ -598,7 +632,7 @@ scm_debug_newcell2 (void)
/* {Scheme Interface to GC}
*/
SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
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
@ -626,7 +660,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
goto retry;
scm_block_gc = 0;
/// ? ?? ?
/// ? ?? ?
local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated;
#ifdef GUILE_NEW_GC_SCHEME
@ -650,7 +684,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
#undef FUNC_NAME
void
void
scm_gc_start (const char *what)
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
@ -659,7 +693,7 @@ scm_gc_start (const char *what)
scm_gc_ports_collected = 0;
}
void
void
scm_gc_end ()
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
@ -668,7 +702,7 @@ scm_gc_end ()
}
SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
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}")
@ -679,7 +713,7 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
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.")
@ -764,7 +798,7 @@ scm_gc_for_alloc (scm_freelist_t *freelist)
}
SCM
SCM
scm_gc_for_newcell (scm_freelist_t *freelist)
{
SCM fl;
@ -860,7 +894,7 @@ scm_igc (const char *what)
}
#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
@ -914,13 +948,13 @@ scm_igc (const char *what)
/* 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 ();
@ -936,14 +970,14 @@ scm_igc (const char *what)
}
/* {Mark/Sweep}
/* {Mark/Sweep}
*/
/* Mark an object precisely.
*/
void
void
scm_gc_mark (SCM p)
{
register long i;
@ -1016,7 +1050,7 @@ gc_mark_nimp:
/* We're using SCM_GCCDR here like STRUCT_DATA, except
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]);
@ -1127,7 +1161,7 @@ gc_mark_nimp:
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;
@ -1144,7 +1178,7 @@ gc_mark_nimp:
kvpair = SCM_CAR (alist);
next_alist = SCM_CDR (alist);
/*
/*
* Do not do this:
* SCM_SETGCMARK (alist);
* SCM_SETGCMARK (kvpair);
@ -1239,7 +1273,7 @@ gc_mark_nimp:
/* Mark a Region Conservatively
*/
void
void
scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
{
register long m = n;
@ -1292,7 +1326,9 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
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]);
if ( scm_heap_table[seg_id].span == 1
|| SCM_DOUBLE_CELLP (*(SCM **) (& x[m])))
scm_gc_mark (*(SCM *) & x[m]);
break;
}
@ -1311,7 +1347,7 @@ scm_cellp (SCM value)
{
register int i, j;
register SCM_CELLPTR ptr;
if SCM_CELLP (*(SCM **) (& value))
{
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
@ -1390,7 +1426,7 @@ scm_mark_weak_vector_spines ()
alist = ptr[j];
while ( SCM_CONSP (alist)
&& !SCM_GCMARKP (alist)
&& !SCM_GCMARKP (alist)
&& SCM_CONSP (SCM_CAR (alist)))
{
SCM_SETGCMARK (alist);
@ -1426,12 +1462,12 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist)
freelist->collected +=
freelist->span * (freelist->cluster_size - freelist->left_to_collect);
}
freelist->grow_heap_p = (freelist->collected < freelist->gc_trigger);
}
#endif
void
void
scm_gc_sweep ()
{
register SCM_CELLPTR ptr;
@ -1459,7 +1495,7 @@ scm_gc_sweep ()
for (i = 0; i < scm_n_heap_segs; i++)
scm_heap_table[i].freelist->cells = SCM_EOL;
#endif
for (i = 0; i < scm_n_heap_segs; i++)
{
#ifdef GUILE_NEW_GC_SCHEME
@ -1482,8 +1518,8 @@ scm_gc_sweep ()
#endif
span = scm_heap_table[i].span;
ptr = CELL_UP (scm_heap_table[i].bounds[0]);
seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
ptr = CELL_UP (scm_heap_table[i].bounds[0], span);
seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr;
for (j = seg_size + span; j -= span; ptr += span)
{
#ifdef SCM_POINTERS_MUNGED
@ -1686,7 +1722,7 @@ scm_gc_sweep ()
SCM_SETCAR (scmptr, nfreelist);
*freelist->clustertail = scmptr;
freelist->clustertail = SCM_CDRLOC (scmptr);
nfreelist = SCM_EOL;
freelist->collected += span * freelist->cluster_size;
left_to_collect = freelist->cluster_size;
@ -1702,7 +1738,7 @@ scm_gc_sweep ()
SCM_SETCDR (scmptr, nfreelist);
nfreelist = scmptr;
}
continue;
c8mrkcontinue:
SCM_CLRGC8MARK (scmptr);
@ -1750,17 +1786,17 @@ scm_gc_sweep ()
scm_map_free_list ();
#endif
}
#ifdef GUILE_NEW_GC_SCHEME
gc_sweep_freelist_finish (&scm_master_freelist);
gc_sweep_freelist_finish (&scm_master_freelist2);
/* 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, w;
@ -1790,7 +1826,7 @@ scm_gc_sweep ()
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);
@ -1838,7 +1874,7 @@ scm_gc_sweep ()
* 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
* 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.
@ -1924,7 +1960,7 @@ scm_must_realloc (void *where,
return 0; /* never reached */
}
void
void
scm_must_free (void *obj)
{
if (obj)
@ -1999,7 +2035,7 @@ scm_sizet scm_max_segment_size;
*/
SCM_CELLPTR scm_heap_org;
struct scm_heap_seg_data * scm_heap_table = 0;
scm_heap_seg_data_t * scm_heap_table = 0;
int scm_n_heap_segs = 0;
/* init_heap_seg
@ -2013,7 +2049,7 @@ int scm_n_heap_segs = 0;
*/
static scm_sizet
static scm_sizet
init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
{
register SCM_CELLPTR ptr;
@ -2027,19 +2063,17 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
int new_seg_index;
int n_new_cells;
int span = freelist->span;
if (seg_org == NULL)
return 0;
ptr = seg_org;
ptr = CELL_UP (seg_org, span);
size = (size / sizeof (scm_cell) / span) * span * sizeof (scm_cell);
/* Compute the ceiling on valid object pointers w/in this segment.
/* Compute the ceiling on valid object pointers w/in this segment.
*/
seg_end = CELL_DN ((char *) ptr + size);
seg_end = CELL_DN ((char *) seg_org + size, span);
/* Find the right place and insert the segment record.
/* Find the right place and insert the segment record.
*
*/
for (new_seg_index = 0;
@ -2053,7 +2087,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
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;
@ -2063,9 +2097,9 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end;
/* Compute the least valid object pointer w/in this segment
/* Compute the least valid object pointer w/in this segment
*/
ptr = CELL_UP (ptr);
ptr = CELL_UP (ptr, span);
/*n_new_cells*/
@ -2075,8 +2109,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
freelist->heap_size += n_new_cells;
/* Partition objects in this segment into clusters
*/
/* Partition objects in this segment into clusters */
{
SCM clusters;
SCM *clusterp = &clusters;
@ -2092,10 +2125,9 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
n_new_cells -= n_cluster_cells;
}
else
{
seg_end = ptr + n_new_cells;
n_new_cells = 0;
}
/* [cmm] looks like the segment size doesn't divide cleanly by
cluster size. bad cmm! */
abort();
/* Allocate cluster spine
*/
@ -2103,7 +2135,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
SCM_SETCAR (*clusterp, PTR2SCM (ptr + span));
clusterp = SCM_CDRLOC (*clusterp);
ptr += span;
while (ptr < seg_end)
{
#ifdef SCM_POINTERS_MUNGED
@ -2116,7 +2148,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL);
}
/* Patch up the last cluster pointer in the segment
* to join it to the input freelist.
*/
@ -2129,7 +2161,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
#else /* GUILE_NEW_GC_SCHEME */
/* Prepend objects in this segment to the freelist.
/* Prepend objects in this segment to the freelist.
*/
while (ptr < seg_end)
{
@ -2147,7 +2179,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
* to join it to the input freelist.
*/
SCM_SETCDR (PTR2SCM (ptr), freelist->cells);
freelist->cells = PTR2SCM (CELL_UP (seg_org));
freelist->cells = PTR2SCM (CELL_UP (seg_org, span));
freelist->heap_size += n_new_cells;
@ -2162,14 +2194,29 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
#endif
}
#ifndef GUILE_NEW_GC_SCHEME
#define round_to_cluster_size(freelist, len) len
#else
static void
static scm_sizet
round_to_cluster_size (scm_freelist_t *freelist, scm_sizet len)
{
scm_sizet cluster_size_in_bytes = CLUSTER_SIZE_IN_BYTES (freelist);
return
(len + cluster_size_in_bytes - 1) / cluster_size_in_bytes * cluster_size_in_bytes
+ ALIGNMENT_SLACK (freelist);
}
#endif
static void
alloc_some_heap (scm_freelist_t *freelist)
{
struct scm_heap_seg_data * tmptable;
scm_heap_seg_data_t * tmptable;
SCM_CELLPTR ptr;
scm_sizet len;
/* Critical code sections (such as the garbage collector)
* aren't supposed to add heap segments.
*/
@ -2180,9 +2227,9 @@ alloc_some_heap (scm_freelist_t *freelist)
* 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);
len = (1 + scm_n_heap_segs) * sizeof (scm_heap_seg_data_t);
SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *)
SCM_SYSCALL (tmptable = ((scm_heap_seg_data_t *)
realloc ((char *)scm_heap_table, len)));
if (!tmptable)
scm_wta (SCM_UNDEFINED, "could not grow", "hplims");
@ -2191,7 +2238,7 @@ alloc_some_heap (scm_freelist_t *freelist)
/* Pick a size for the new heap segment.
* The rule for picking the size of a segment is explained in
* The rule for picking the size of a segment is explained in
* gc.h
*/
#ifdef GUILE_NEW_GC_SCHEME
@ -2207,7 +2254,7 @@ alloc_some_heap (scm_freelist_t *freelist)
len = min_cells + 1;
len *= sizeof (scm_cell);
}
if (len > scm_max_segment_size)
len = scm_max_segment_size;
#else
@ -2225,18 +2272,24 @@ alloc_some_heap (scm_freelist_t *freelist)
{
scm_sizet smallest;
#ifndef GUILE_NEW_GC_SCHEME
smallest = (freelist->span * sizeof (scm_cell));
#else
smallest = CLUSTER_SIZE_IN_BYTES (freelist);
#endif
if (len < smallest)
len = (freelist->span * sizeof (scm_cell));
len = smallest;
/* Allocate with decaying ambition. */
while ((len >= SCM_MIN_HEAP_SEG_SIZE)
&& (len >= smallest))
{
SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
scm_sizet rounded_len = round_to_cluster_size(freelist, len);
SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (rounded_len));
if (ptr)
{
init_heap_seg (ptr, len, freelist);
init_heap_seg (ptr, rounded_len, freelist);
return;
}
len /= 2;
@ -2248,7 +2301,7 @@ alloc_some_heap (scm_freelist_t *freelist)
SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
(SCM name),
"")
#define FUNC_NAME s_scm_unhash_name
@ -2399,13 +2452,14 @@ cleanup (int status, void *arg)
static int
make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist)
{
if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
init_heap_size,
scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size);
if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
rounded_size,
freelist))
{
init_heap_size = SCM_HEAP_SEG_SIZE;
if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size),
init_heap_size,
rounded_size = round_to_cluster_size (freelist, SCM_HEAP_SEG_SIZE);
if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
rounded_size,
freelist))
return 1;
}
@ -2413,7 +2467,7 @@ make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist)
scm_expmem = 1;
freelist->grow_heap_p = (freelist->heap_size < freelist->gc_trigger);
return 0;
}
@ -2487,8 +2541,8 @@ scm_init_storage (scm_sizet init_heap_size, scm_sizet init_heap2_size)
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) * 2, "hplims"));
scm_heap_table = ((scm_heap_seg_data_t *)
scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims"));
#ifdef GUILE_NEW_GC_SCHEME
if (make_initial_segment (init_heap_size_1, &scm_master_freelist) ||
@ -2500,7 +2554,7 @@ scm_init_storage (scm_sizet init_heap_size, scm_sizet init_heap2_size)
return 1;
#endif
scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0], 1);
/* scm_hplims[0] can change. do not remove scm_heap_org */
scm_weak_vectors = SCM_EOL;

57
libguile/gc.h
View file

@ -3,17 +3,17 @@
#ifndef GCH
#define GCH
/* Copyright (C) 1995, 96, 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
* 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,
@ -60,56 +60,23 @@
: SCM_GCMARKP(x))
#define SCM_NMARKEDP(x) (!SCM_MARKEDP(x))
extern struct scm_heap_seg_data *scm_heap_table;
extern struct scm_heap_seg_data_t *scm_heap_table;
extern int scm_n_heap_segs;
extern int scm_take_stdin;
extern int scm_block_gc;
extern int scm_gc_heap_lock;
typedef struct scm_freelist_t {
/* collected cells */
SCM cells;
#ifdef GUILE_NEW_GC_SCHEME
/* number of cells left to collect before cluster is full */
unsigned int left_to_collect;
/* a list of freelists, each of size gc_trigger,
except the last one which may be shorter */
SCM clusters;
SCM *clustertail;
/* this is the number of cells in each cluster, including the spine cell */
int cluster_size;
/* set to grow the heap when we run out of clusters
*/
int grow_heap_p;
/* minimum number of objects allocated before GC is triggered
*/
int gc_trigger;
/* defines gc_trigger as percent of heap size
* 0 => constant trigger
*/
int gc_trigger_fraction;
#endif
/* number of cells per object on this list */
int span;
/* number of collected cells during last GC */
int collected;
/* total number of cells in heap segments
* belonging to this list.
*/
int heap_size;
} scm_freelist_t;
extern scm_sizet scm_max_segment_size;
extern SCM_CELLPTR scm_heap_org;
#ifdef GUILE_NEW_GC_SCHEME
extern SCM scm_freelist;
extern scm_freelist_t scm_master_freelist;
extern struct scm_freelist_t scm_master_freelist;
extern SCM scm_freelist2;
extern scm_freelist_t scm_master_freelist2;
extern struct scm_freelist_t scm_master_freelist2;
#else
extern scm_freelist_t scm_freelist;
extern scm_freelist_t scm_freelist2;
extern struct scm_freelist_t scm_freelist;
extern struct scm_freelist_t scm_freelist2;
#endif
extern unsigned long scm_gc_cells_collected;
extern unsigned long scm_gc_malloc_collected;
@ -136,14 +103,14 @@ extern SCM scm_gc_stats (void);
extern void scm_gc_start (const char *what);
extern void scm_gc_end (void);
extern SCM scm_gc (void);
extern void scm_gc_for_alloc (scm_freelist_t *freelist);
extern void scm_gc_for_alloc (struct scm_freelist_t *freelist);
#ifdef GUILE_NEW_GC_SCHEME
extern SCM scm_gc_for_newcell (scm_freelist_t *master, SCM *freelist);
extern SCM scm_gc_for_newcell (struct scm_freelist_t *master, SCM *freelist);
#if 0
extern void scm_alloc_cluster (scm_freelist_t *master);
extern void scm_alloc_cluster (struct scm_freelist_t *master);
#endif
#else
extern SCM scm_gc_for_newcell (scm_freelist_t *freelist);
extern SCM scm_gc_for_newcell (struct scm_freelist_t *freelist);
#endif
extern void scm_igc (const char *what);
extern void scm_gc_mark (SCM p);

3
libguile/tags.h
View file

@ -305,6 +305,9 @@ typedef void * SCM;
#define SCM_CELLP(x) (!SCM_NCELLP (x))
#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & SCM_UNPACK (x))
#define SCM_DOUBLE_CELLP(x) (!SCM_NDOUBLE_CELLP (x))
#define SCM_NDOUBLE_CELLP(x) ((2 * sizeof (scm_cell) - 1) & SCM_UNPACK (x))
/* See numbers.h for macros relating to immediate integers.
*/