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> 2000-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
* _scm.h: Don't include async.h everywhere... * _scm.h: Don't include async.h everywhere...
@ -69,13 +91,13 @@
GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2 GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2
2000-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se> 2000-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* __scm.h (GC_FREE_SEGMENTS): Disable this until we have made * __scm.h (GC_FREE_SEGMENTS): Disable this until we have made
freeing of segment work with the new GC scheme. (Thanks to freeing of segment work with the new GC scheme. (Thanks to
Michael Livshin.) Oops, also happened to make GUILE_NEW_GC_SCHEME 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 the default, but I'll let this change stay in CVS Guile since this
code is not expected to contain serious bugs. code is not expected to contain serious bugs.
2000-03-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> 2000-03-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* gc.c, gc.h (scm_map_free_list): Define also if GUILE_DEBUG is * 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> 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 * 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 make guile-procedures.txt depend on DOT_DOC_FILES instead of
*.doc, so that rebuilding it works. *.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 The following change to init.c is only enabled if Guile was
configured with --enable-guile-debug. configured with --enable-guile-debug.
* init.c (scm_i_getenv_int): New function. * init.c (scm_i_getenv_int): New function.
(scm_boot_guile_1): Use the environment variables (scm_boot_guile_1): Use the environment variables
GUILE_INIT_HEAP_SIZE, GUILE_INIT_HEAP_SIZE2 to select heap size if 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. * async.c, async.h: made async representation a double cell.
* dynl.c: made dynamic_obj representation a double cell. * dynl.c: made dynamic_obj representation a double cell.
2000-03-13 Gary Houston <ghouston@arglist.com> 2000-03-13 Gary Houston <ghouston@arglist.com>
* ports.c (flush_void_port): renamed to flush_port_default. * 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 that we can't use autoconf for this. Autoconf itself relies on
the existence of `sed' somewhere on your path.) (Thanks to Dirk the existence of `sed' somewhere on your path.) (Thanks to Dirk
Herrman.) Herrman.)
2000-03-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> 2000-03-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* Makefile.am (libguile_la_SOURCES): Moved iselect.c here from * 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. * struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes.
2000-03-12 Marius Vollmer <mvo@zagadka.ping.de> 2000-03-12 Marius Vollmer <mvo@zagadka.ping.de>
* init.c (scm_standard_stream_to_port): Check whether the file * init.c (scm_standard_stream_to_port): Check whether the file
descriptor is valid and substitute "/dev/null" when not. descriptor is valid and substitute "/dev/null" when not.
2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> 2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
* coop-defs.h (struct timespec): Conditionally defined. * 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 code. It moves things to better places, makes arguments more
consistent with the POSIX API (which is used in GNOME's glib), and consistent with the POSIX API (which is used in GNOME's glib), and
adds new functionality. adds new functionality.
* readline.c (scm_init_readline): Added new arg to scm_init_mutex. * readline.c (scm_init_readline): Added new arg to scm_init_mutex.
* coop-defs.h (scm_mutex_trylock): New macro: alias for * coop-defs.h (scm_mutex_trylock): New macro: alias for
coop_mutex_trylock. coop_mutex_trylock.
(scm_cond_init): Changed definition to (scm_cond_init): Changed definition to
coop_new_condition_variable_init. coop_new_condition_variable_init.
* coop.c: #include <errno.h> * coop.c: #include <errno.h>
(coop_timeout_qinsert): Moved here from iselect.c (coop_timeout_qinsert): Moved here from iselect.c
(coop_new_mutex_init, coop_new_condition_variable_init): New (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> 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. eliminating some warnings.
* unif.c, strports.c, print.c, options.c: Fix some warnings on * 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 storing tags and immediates (now a long int). Introduced
SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious
code in the process: arbiter.c (use macros), unif.c (scm_array_p), 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> 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 * 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> 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. added append docs from R4RS.
* strings.c: Docstring typo fix, + eliminate unneeded IMP tests. * 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 * chars.h: Provide SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR and
deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann! deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann!
* *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout. * *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout.
Drop use of SCM_P for function prototypes... assume an ANSI C Drop use of SCM_P for function prototypes... assume an ANSI C
compiler. Thanks Dirk Hermann! 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> 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, * 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 strings.c, variable.c: Added lots of documentation, cleaned up
some existing documentation. Occasionally changed formal params some existing documentation. Occasionally changed formal params
to match docs. Also folded an #ifdef into the inners of a 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>. * 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>. * error.c, gh_data.c, ports.c, script.c, strop.c: include <string.h>.
* strings.c (scm_string_ref): make the 2nd argument compulsory. * strings.c (scm_string_ref): make the 2nd argument compulsory.
previously it defaulted to zero for no good reason that I can see. previously it defaulted to zero for no good reason that I can see.
use a local variable for SCM_INUM (k). replace 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 "select" tests port buffers for the ability to provide input
or accept output. Previously only the underlying file descriptors or accept output. Previously only the underlying file descriptors
were checked. Rewrote the docstring. were checked. Rewrote the docstring.
Thu Jan 27 10:14:25 2000 Greg J. Badros <gjb@cs.washington.edu> Thu Jan 27 10:14:25 2000 Greg J. Badros <gjb@cs.washington.edu>
* vectors.c, symbols.c, strorder.c: Documentation cut and pasted * 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> 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' suggests removing tag.c altogether (and using a new `class-of'
instead). instead).
* strings.c: Added documentation from Gregg A. Reynolds. Edited * strings.c: Added documentation from Gregg A. Reynolds. Edited
a bit by me to use FOO instead of @var{foo} and to have the 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. (rnrs) note.
* gsubr.c: Do not use SCM_DEFINE for `gsubr-apply'. Register the * 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. * eq.c: Added docs for eq?, eqv? equal? abridged from R4RS.
* boolean.c: Added docs for `not', `boolean?' (by hand). * boolean.c: Added docs for `not', `boolean?' (by hand).
Tue Jan 25 13:28:56 2000 Greg J. Badros <gjb@cs.washington.edu> Tue Jan 25 13:28:56 2000 Greg J. Badros <gjb@cs.washington.edu>
* random.c: Added documentation, from SLIB page: * 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> 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). not defined (thanks to Richard Y. Kim).
Thu Jan 20 13:00:38 2000 Greg J. Badros <gjb@cs.washington.edu> 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, stacks.c, stime.c, strings.c, strop.c, strports.c, struct.c,
symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c, symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c,
weaks.c: Converted docstrings to ANSI C format. weaks.c: Converted docstrings to ANSI C format.
* filesys.c (scm_chmod), simpos.c (scm_system), version * filesys.c (scm_chmod), simpos.c (scm_system), version
(scm_version), vports (scm_make_soft_port): Escape " occuring (scm_version), vports (scm_make_soft_port): Escape " occuring
inside docstring. 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-doc-snarf.in: Use new $fullfilename for running
guile-func-name-check, and put "$fullfilename" and "$filename" in guile-func-name-check, and put "$fullfilename" and "$filename" in
quotes at uses to make sure re-splitting on whitespace does not 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 I sure hope we never have to deal with that! :-) ). Thanks to
Mikael for pointing out the source_dir != build_dir was broken. 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 * ramap.c: Fix #if 0'd out code to be syntactically acceptable to
guile-func-name-check. 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. doing the snarf.
Tue Jan 11 11:31:10 2000 Greg J. Badros <gjb@cs.washington.edu> 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' * print.h, print.c (scm_simple_format): Added `simple-format'
primitive. It's the old scm_display_error, with ARGS now a rest 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 new capabilities inspired by `format' -- #t as destination means
current-output-port, #f means return the formatted text as a current-output-port, #f means return the formatted text as a
string. string.
@ -873,7 +895,7 @@ Tue Jan 11 10:41:46 2000 Greg J. Badros <gjb@cs.washington.edu>
* dynl.c: Use ANSI prototypes. * dynl.c: Use ANSI prototypes.
(sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen. (sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen.
* scmconfig.h.in: Do not change, as it is automatically generated. * scmconfig.h.in: Do not change, as it is automatically generated.
1999-07-25 Thomas Tanner <tanner@ffii.org> 1999-07-25 Thomas Tanner <tanner@ffii.org>
* dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c: deleted * 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 scm_lookupcar1: throw an error with key 'unbound-variable instead
of 'misc-error when an unbound variable is encountered. 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), scm_symlink, scm_readlink, scm_lstat),
posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp, posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp,
scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice, scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice,
scm_sync), scm_sync),
simpos.c (scm_system), simpos.c (scm_system),
stime.c (scm_times, scm_strptime): stime.c (scm_times, scm_strptime):
move the HAVE_XXX feature tests out of the procedure bodies. move the HAVE_XXX feature tests out of the procedure bodies.
don't use SCM_SYSMISSING. 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 * scm_validate.h (SCM_OUT_OF_RANGE): Use scm_out_of_range_pos to
report the position of the argument. 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 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. * 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> 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 this by using SCM_ARG2 instead of `2' in the SCM_VALIDATE_CONS
macro call. 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. formal in the current argument snarfing check.
* snarf.h: Give new definition of SCM_ASSERT when in * 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. guile-snarf.awk script uses to verify argument/position matching.
* ramap.c: Remove extraneous #undef FUNC_NAME. * 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> 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 * 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. to stdout instead of directly into the file.
Wed Jan 5 08:15:04 2000 Greg J. Badros <gjb@cs.washington.edu> 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) 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 * 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 * pairs.h: Added a comment about the need for the SCM_SETCAR in
SCM_NEWCELL macro. 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. /* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option) * the Free Software Foundation; either version 2, or (at your option)
* any later version. * any later version.
* *
* This program is distributed in the hope that it will be useful, * This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of * but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details. * GNU General Public License for more details.
* *
* You should have received a copy of the GNU General Public License * You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to * along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
@ -79,7 +79,7 @@
/* {heap tuning parameters} /* {heap tuning parameters}
* *
* These are parameters for controlling memory allocation. The heap * These are parameters for controlling memory allocation. The heap
* is the area out of which scm_cons, and object headers are allocated. * 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 * 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 * 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 * 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 * 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_EXPHEAP(scm_heap_size) when more heap is needed.
* *
@ -103,13 +103,13 @@
* is needed. * is needed.
* *
* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will * 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 * 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 by a GC triggered by must_malloc. If less than this is
* reclaimed, the trigger threshold is raised. [I don't know what a * 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 * 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)) #define SCM_INIT_HEAP_SIZE_1 (40000L * sizeof (scm_cell))
@ -145,23 +145,58 @@
#ifdef PROT386 #ifdef PROT386
/*in 386 protected mode we must only adjust the offset */ /*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_UP(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&(FP_OFF(p)+8*(span)-1))
# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p)) # define CELL_DN(p, span) MK_FP(FP_SEG(p), ~(8*(span)-1)&FP_OFF(p))
#else #else
# ifdef _UNICOS # ifdef _UNICOS
# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L)) # define CELL_UP(p, span) (SCM_CELLPTR)(~(span) & ((long)(p)+(span)))
# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p)) # define CELL_DN(p, span) (SCM_CELLPTR)(~(span) & (long)(p))
# else # else
# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L)) # define CELL_UP(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & ((long)(p)+sizeof(scm_cell)*(span)-1L))
# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p)) # define CELL_DN(p, span) (SCM_CELLPTR)(~(sizeof(scm_cell)*(span)-1L) & (long)(p))
# endif /* UNICOS */ # endif /* UNICOS */
#endif /* PROT386 */ #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 /* 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 #ifdef GUILE_NEW_GC_SCHEME
SCM scm_freelist = SCM_EOL; SCM scm_freelist = SCM_EOL;
scm_freelist_t scm_master_freelist = { 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_heap_segments, "cell-heap-segments");
SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
typedef struct scm_heap_seg_data_t
struct scm_heap_seg_data
{ {
/* lower and upper bounds of the segment */ /* lower and upper bounds of the segment */
SCM_CELLPTR bounds[2]; 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. SEG_DATA, and mark the object iff the function returns non-zero.
At the moment, I don't think anyone uses this. */ At the moment, I don't think anyone uses this. */
int (*valid) (); 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; int last_seg = -1, count = 0;
SCM f; SCM f;
for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f)) for (f = freelist; SCM_NIMP (f); f = SCM_CDR (f))
{ {
int this_seg = which_seg (f); int this_seg = which_seg (f);
@ -302,7 +336,7 @@ map_free_list (scm_freelist_t *freelist)
{ {
int last_seg = -1, count = 0; int last_seg = -1, count = 0;
SCM f; SCM f;
for (f = freelist->cells; SCM_NIMP (f); f = SCM_CDR (f)) for (f = freelist->cells; SCM_NIMP (f); f = SCM_CDR (f))
{ {
int this_seg = which_seg (f); int this_seg = which_seg (f);
@ -323,7 +357,7 @@ map_free_list (scm_freelist_t *freelist)
} }
#endif #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" "Print debugging information about the free-list.\n"
"`map-free-list' is only included in --enable-guile-debug builds of Guile.") "`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); 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" "Print debugging information about the free-list.\n"
"`free-list-length' is only included in --enable-guile-debug builds of Guile.") "`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; 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), (SCM flag),
"If FLAG is #t, check the freelist for consistency on each cell allocation.\n" "If FLAG is #t, check the freelist for consistency on each cell allocation.\n"
"This procedure only exists because the GUILE_DEBUG_FREELIST \n" "This procedure only exists because the GUILE_DEBUG_FREELIST \n"
@ -598,7 +632,7 @@ scm_debug_newcell2 (void)
/* {Scheme Interface to GC} /* {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. ") "Returns an association list of statistics about Guile's current use of storage. ")
#define FUNC_NAME s_scm_gc_stats #define FUNC_NAME s_scm_gc_stats
@ -626,7 +660,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
goto retry; goto retry;
scm_block_gc = 0; scm_block_gc = 0;
/// ? ?? ? /// ? ?? ?
local_scm_mtrigger = scm_mtrigger; local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated; local_scm_mallocated = scm_mallocated;
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
@ -650,7 +684,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
void void
scm_gc_start (const char *what) scm_gc_start (const char *what)
{ {
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); 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; scm_gc_ports_collected = 0;
} }
void void
scm_gc_end () scm_gc_end ()
{ {
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; 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), (SCM obj),
"Return an integer that for the lifetime of @var{obj} is uniquely\n" "Return an integer that for the lifetime of @var{obj} is uniquely\n"
"returned by this function for @var{obj}") "returned by this function for @var{obj}")
@ -679,7 +713,7 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
#undef FUNC_NAME #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" "Scans all of SCM objects and reclaims for further use those that are\n"
"no longer accessible.") "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_gc_for_newcell (scm_freelist_t *freelist)
{ {
SCM fl; SCM fl;
@ -860,7 +894,7 @@ scm_igc (const char *what)
} }
#ifndef USE_THREADS #ifndef USE_THREADS
/* Protect from the C stack. This must be the first marking /* Protect from the C stack. This must be the first marking
* done because it provides information about what objects * done because it provides information about what objects
* are "in-use" by the C code. "in-use" objects are those * 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 /* FIXME: we should have a means to register C functions to be run
* in different phases of GC * in different phases of GC
*/ */
scm_mark_subr_table (); scm_mark_subr_table ();
#ifndef USE_THREADS #ifndef USE_THREADS
scm_gc_mark (scm_root->handle); scm_gc_mark (scm_root->handle);
#endif #endif
scm_mark_weak_vector_spines (); scm_mark_weak_vector_spines ();
scm_guardian_zombify (); scm_guardian_zombify ();
@ -936,14 +970,14 @@ scm_igc (const char *what)
} }
/* {Mark/Sweep} /* {Mark/Sweep}
*/ */
/* Mark an object precisely. /* Mark an object precisely.
*/ */
void void
scm_gc_mark (SCM p) scm_gc_mark (SCM p)
{ {
register long i; register long i;
@ -1016,7 +1050,7 @@ gc_mark_nimp:
/* We're using SCM_GCCDR here like STRUCT_DATA, except /* We're using SCM_GCCDR here like STRUCT_DATA, except
that it removes the mark */ that it removes the mark */
mem = (SCM *)SCM_GCCDR (ptr); mem = (SCM *)SCM_GCCDR (ptr);
if (SCM_UNPACK (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY) if (SCM_UNPACK (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
{ {
scm_gc_mark (mem[scm_struct_i_procedure]); scm_gc_mark (mem[scm_struct_i_procedure]);
@ -1127,7 +1161,7 @@ gc_mark_nimp:
len = SCM_LENGTH (ptr); len = SCM_LENGTH (ptr);
weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
for (x = 0; x < len; ++x) for (x = 0; x < len; ++x)
{ {
SCM alist; SCM alist;
@ -1144,7 +1178,7 @@ gc_mark_nimp:
kvpair = SCM_CAR (alist); kvpair = SCM_CAR (alist);
next_alist = SCM_CDR (alist); next_alist = SCM_CDR (alist);
/* /*
* Do not do this: * Do not do this:
* SCM_SETGCMARK (alist); * SCM_SETGCMARK (alist);
* SCM_SETGCMARK (kvpair); * SCM_SETGCMARK (kvpair);
@ -1239,7 +1273,7 @@ gc_mark_nimp:
/* Mark a Region Conservatively /* Mark a Region Conservatively
*/ */
void void
scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
{ {
register long m = 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 if ( !scm_heap_table[seg_id].valid
|| scm_heap_table[seg_id].valid (ptr, || scm_heap_table[seg_id].valid (ptr,
&scm_heap_table[seg_id])) &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; break;
} }
@ -1311,7 +1347,7 @@ scm_cellp (SCM value)
{ {
register int i, j; register int i, j;
register SCM_CELLPTR ptr; register SCM_CELLPTR ptr;
if SCM_CELLP (*(SCM **) (& value)) if SCM_CELLP (*(SCM **) (& value))
{ {
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
@ -1390,7 +1426,7 @@ scm_mark_weak_vector_spines ()
alist = ptr[j]; alist = ptr[j];
while ( SCM_CONSP (alist) while ( SCM_CONSP (alist)
&& !SCM_GCMARKP (alist) && !SCM_GCMARKP (alist)
&& SCM_CONSP (SCM_CAR (alist))) && SCM_CONSP (SCM_CAR (alist)))
{ {
SCM_SETGCMARK (alist); SCM_SETGCMARK (alist);
@ -1426,12 +1462,12 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist)
freelist->collected += freelist->collected +=
freelist->span * (freelist->cluster_size - freelist->left_to_collect); freelist->span * (freelist->cluster_size - freelist->left_to_collect);
} }
freelist->grow_heap_p = (freelist->collected < freelist->gc_trigger); freelist->grow_heap_p = (freelist->collected < freelist->gc_trigger);
} }
#endif #endif
void void
scm_gc_sweep () scm_gc_sweep ()
{ {
register SCM_CELLPTR ptr; register SCM_CELLPTR ptr;
@ -1459,7 +1495,7 @@ scm_gc_sweep ()
for (i = 0; i < scm_n_heap_segs; i++) for (i = 0; i < scm_n_heap_segs; i++)
scm_heap_table[i].freelist->cells = SCM_EOL; scm_heap_table[i].freelist->cells = SCM_EOL;
#endif #endif
for (i = 0; i < scm_n_heap_segs; i++) for (i = 0; i < scm_n_heap_segs; i++)
{ {
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
@ -1482,8 +1518,8 @@ scm_gc_sweep ()
#endif #endif
span = scm_heap_table[i].span; span = scm_heap_table[i].span;
ptr = CELL_UP (scm_heap_table[i].bounds[0]); ptr = CELL_UP (scm_heap_table[i].bounds[0], span);
seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr; seg_size = CELL_DN (scm_heap_table[i].bounds[1], span) - ptr;
for (j = seg_size + span; j -= span; ptr += span) for (j = seg_size + span; j -= span; ptr += span)
{ {
#ifdef SCM_POINTERS_MUNGED #ifdef SCM_POINTERS_MUNGED
@ -1686,7 +1722,7 @@ scm_gc_sweep ()
SCM_SETCAR (scmptr, nfreelist); SCM_SETCAR (scmptr, nfreelist);
*freelist->clustertail = scmptr; *freelist->clustertail = scmptr;
freelist->clustertail = SCM_CDRLOC (scmptr); freelist->clustertail = SCM_CDRLOC (scmptr);
nfreelist = SCM_EOL; nfreelist = SCM_EOL;
freelist->collected += span * freelist->cluster_size; freelist->collected += span * freelist->cluster_size;
left_to_collect = freelist->cluster_size; left_to_collect = freelist->cluster_size;
@ -1702,7 +1738,7 @@ scm_gc_sweep ()
SCM_SETCDR (scmptr, nfreelist); SCM_SETCDR (scmptr, nfreelist);
nfreelist = scmptr; nfreelist = scmptr;
} }
continue; continue;
c8mrkcontinue: c8mrkcontinue:
SCM_CLRGC8MARK (scmptr); SCM_CLRGC8MARK (scmptr);
@ -1750,17 +1786,17 @@ scm_gc_sweep ()
scm_map_free_list (); scm_map_free_list ();
#endif #endif
} }
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
gc_sweep_freelist_finish (&scm_master_freelist); gc_sweep_freelist_finish (&scm_master_freelist);
gc_sweep_freelist_finish (&scm_master_freelist2); gc_sweep_freelist_finish (&scm_master_freelist2);
/* When we move to POSIX threads private freelists should probably /* When we move to POSIX threads private freelists should probably
be GC-protected instead. */ be GC-protected instead. */
scm_freelist = SCM_EOL; scm_freelist = SCM_EOL;
scm_freelist2 = SCM_EOL; scm_freelist2 = SCM_EOL;
#endif #endif
/* Scan weak vectors. */ /* Scan weak vectors. */
{ {
SCM *ptr, w; SCM *ptr, w;
@ -1790,7 +1826,7 @@ scm_gc_sweep ()
SCM alist; SCM alist;
int weak_keys; int weak_keys;
int weak_values; int weak_values;
weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
weak_values = SCM_IS_WHVEC_V (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. * Return newly malloced storage or throw an error.
* *
* The parameter WHAT is a string for error reporting. * 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, * allocation, or if the first call to malloc fails,
* garbage collect -- on the presumption that some objects * garbage collect -- on the presumption that some objects
* using malloced storage may be collected. * using malloced storage may be collected.
@ -1924,7 +1960,7 @@ scm_must_realloc (void *where,
return 0; /* never reached */ return 0; /* never reached */
} }
void void
scm_must_free (void *obj) scm_must_free (void *obj)
{ {
if (obj) if (obj)
@ -1999,7 +2035,7 @@ scm_sizet scm_max_segment_size;
*/ */
SCM_CELLPTR scm_heap_org; 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; int scm_n_heap_segs = 0;
/* init_heap_seg /* 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) init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist)
{ {
register SCM_CELLPTR ptr; 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 new_seg_index;
int n_new_cells; int n_new_cells;
int span = freelist->span; int span = freelist->span;
if (seg_org == NULL) if (seg_org == NULL)
return 0; 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; 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) for (i = scm_n_heap_segs; i > new_seg_index; --i)
scm_heap_table[i] = scm_heap_table[i - 1]; scm_heap_table[i] = scm_heap_table[i - 1];
} }
++scm_n_heap_segs; ++scm_n_heap_segs;
scm_heap_table[new_seg_index].valid = 0; 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; 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*/ /*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; freelist->heap_size += n_new_cells;
/* Partition objects in this segment into clusters /* Partition objects in this segment into clusters */
*/
{ {
SCM clusters; SCM clusters;
SCM *clusterp = &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; n_new_cells -= n_cluster_cells;
} }
else else
{ /* [cmm] looks like the segment size doesn't divide cleanly by
seg_end = ptr + n_new_cells; cluster size. bad cmm! */
n_new_cells = 0; abort();
}
/* Allocate cluster spine /* 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)); SCM_SETCAR (*clusterp, PTR2SCM (ptr + span));
clusterp = SCM_CDRLOC (*clusterp); clusterp = SCM_CDRLOC (*clusterp);
ptr += span; ptr += span;
while (ptr < seg_end) while (ptr < seg_end)
{ {
#ifdef SCM_POINTERS_MUNGED #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); SCM_SETCDR (PTR2SCM (ptr - span), SCM_EOL);
} }
/* Patch up the last cluster pointer in the segment /* Patch up the last cluster pointer in the segment
* to join it to the input freelist. * 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 */ #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) 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. * to join it to the input freelist.
*/ */
SCM_SETCDR (PTR2SCM (ptr), freelist->cells); 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; 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 #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) alloc_some_heap (scm_freelist_t *freelist)
{ {
struct scm_heap_seg_data * tmptable; scm_heap_seg_data_t * tmptable;
SCM_CELLPTR ptr; SCM_CELLPTR ptr;
scm_sizet len; scm_sizet len;
/* Critical code sections (such as the garbage collector) /* Critical code sections (such as the garbage collector)
* aren't supposed to add heap segments. * 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 * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
* only if the allocation of the segment itself succeeds. * 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))); realloc ((char *)scm_heap_table, len)));
if (!tmptable) if (!tmptable)
scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); 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. /* 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 * gc.h
*/ */
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
@ -2207,7 +2254,7 @@ alloc_some_heap (scm_freelist_t *freelist)
len = min_cells + 1; len = min_cells + 1;
len *= sizeof (scm_cell); len *= sizeof (scm_cell);
} }
if (len > scm_max_segment_size) if (len > scm_max_segment_size)
len = scm_max_segment_size; len = scm_max_segment_size;
#else #else
@ -2225,18 +2272,24 @@ alloc_some_heap (scm_freelist_t *freelist)
{ {
scm_sizet smallest; scm_sizet smallest;
#ifndef GUILE_NEW_GC_SCHEME
smallest = (freelist->span * sizeof (scm_cell)); smallest = (freelist->span * sizeof (scm_cell));
#else
smallest = CLUSTER_SIZE_IN_BYTES (freelist);
#endif
if (len < smallest) if (len < smallest)
len = (freelist->span * sizeof (scm_cell)); len = smallest;
/* Allocate with decaying ambition. */ /* Allocate with decaying ambition. */
while ((len >= SCM_MIN_HEAP_SEG_SIZE) while ((len >= SCM_MIN_HEAP_SEG_SIZE)
&& (len >= smallest)) && (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) if (ptr)
{ {
init_heap_seg (ptr, len, freelist); init_heap_seg (ptr, rounded_len, freelist);
return; return;
} }
len /= 2; 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), (SCM name),
"") "")
#define FUNC_NAME s_scm_unhash_name #define FUNC_NAME s_scm_unhash_name
@ -2399,13 +2452,14 @@ cleanup (int status, void *arg)
static int static int
make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist) make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist)
{ {
if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size), scm_sizet rounded_size = round_to_cluster_size (freelist, init_heap_size);
init_heap_size, if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
rounded_size,
freelist)) freelist))
{ {
init_heap_size = SCM_HEAP_SEG_SIZE; rounded_size = round_to_cluster_size (freelist, SCM_HEAP_SEG_SIZE);
if (!init_heap_seg ((SCM_CELLPTR) malloc (init_heap_size), if (!init_heap_seg ((SCM_CELLPTR) malloc (rounded_size),
init_heap_size, rounded_size,
freelist)) freelist))
return 1; return 1;
} }
@ -2413,7 +2467,7 @@ make_initial_segment (scm_sizet init_heap_size, scm_freelist_t *freelist)
scm_expmem = 1; scm_expmem = 1;
freelist->grow_heap_p = (freelist->heap_size < freelist->gc_trigger); freelist->grow_heap_p = (freelist->heap_size < freelist->gc_trigger);
return 0; return 0;
} }
@ -2487,8 +2541,8 @@ scm_init_storage (scm_sizet init_heap_size, scm_sizet init_heap2_size)
j = SCM_HEAP_SEG_SIZE; j = SCM_HEAP_SEG_SIZE;
scm_mtrigger = SCM_INIT_MALLOC_LIMIT; scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
scm_heap_table = ((struct scm_heap_seg_data *) scm_heap_table = ((scm_heap_seg_data_t *)
scm_must_malloc (sizeof (struct scm_heap_seg_data) * 2, "hplims")); scm_must_malloc (sizeof (scm_heap_seg_data_t) * 2, "hplims"));
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
if (make_initial_segment (init_heap_size_1, &scm_master_freelist) || 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; return 1;
#endif #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_hplims[0] can change. do not remove scm_heap_org */
scm_weak_vectors = SCM_EOL; scm_weak_vectors = SCM_EOL;

57
libguile/gc.h
View file

@ -3,17 +3,17 @@
#ifndef GCH #ifndef GCH
#define GCH #define GCH
/* Copyright (C) 1995, 96, 98, 99, 2000 Free Software Foundation, Inc. /* Copyright (C) 1995, 96, 98, 99, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option) * the Free Software Foundation; either version 2, or (at your option)
* any later version. * any later version.
* *
* This program is distributed in the hope that it will be useful, * This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of * but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details. * GNU General Public License for more details.
* *
* You should have received a copy of the GNU General Public License * You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to * along with this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330, * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
@ -60,56 +60,23 @@
: SCM_GCMARKP(x)) : SCM_GCMARKP(x))
#define SCM_NMARKEDP(x) (!SCM_MARKEDP(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_n_heap_segs;
extern int scm_take_stdin; extern int scm_take_stdin;
extern int scm_block_gc; extern int scm_block_gc;
extern int scm_gc_heap_lock; 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_sizet scm_max_segment_size;
extern SCM_CELLPTR scm_heap_org; extern SCM_CELLPTR scm_heap_org;
#ifdef GUILE_NEW_GC_SCHEME #ifdef GUILE_NEW_GC_SCHEME
extern SCM scm_freelist; 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 scm_freelist2;
extern scm_freelist_t scm_master_freelist2; extern struct scm_freelist_t scm_master_freelist2;
#else #else
extern scm_freelist_t scm_freelist; extern struct scm_freelist_t scm_freelist;
extern scm_freelist_t scm_freelist2; extern struct scm_freelist_t scm_freelist2;
#endif #endif
extern unsigned long scm_gc_cells_collected; extern unsigned long scm_gc_cells_collected;
extern unsigned long scm_gc_malloc_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_start (const char *what);
extern void scm_gc_end (void); extern void scm_gc_end (void);
extern SCM scm_gc (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 #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 #if 0
extern void scm_alloc_cluster (scm_freelist_t *master); extern void scm_alloc_cluster (struct scm_freelist_t *master);
#endif #endif
#else #else
extern SCM scm_gc_for_newcell (scm_freelist_t *freelist); extern SCM scm_gc_for_newcell (struct scm_freelist_t *freelist);
#endif #endif
extern void scm_igc (const char *what); extern void scm_igc (const char *what);
extern void scm_gc_mark (SCM p); 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_CELLP(x) (!SCM_NCELLP (x))
#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & SCM_UNPACK (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. /* See numbers.h for macros relating to immediate integers.
*/ */