From a00c95d9c6ef0e219313ed61f8938a2b9ba23d06 Mon Sep 17 00:00:00 2001 From: Michael Livshin Date: Sat, 18 Mar 2000 11:09:41 +0000 Subject: [PATCH] * 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. --- libguile/ChangeLog | 90 ++++++++++------- libguile/gc.c | 246 +++++++++++++++++++++++++++------------------ libguile/gc.h | 57 +++-------- libguile/tags.h | 3 + 4 files changed, 221 insertions(+), 175 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2eaf597b2..3057073c8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-03-18 Michael Livshin + + * 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 * _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 - + * __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 * 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 Wed Mar 15 08:24:58 2000 Greg J. Badros * 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 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 * async.c, async.h: made async representation a double cell. * dynl.c: made dynamic_obj representation a double cell. - + 2000-03-13 Gary Houston * ports.c (flush_void_port): renamed to flush_port_default. @@ -294,7 +316,7 @@ Wed Mar 15 08:12:14 2000 Greg J. Badros 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 * Makefile.am (libguile_la_SOURCES): Moved iselect.c here from @@ -364,10 +386,10 @@ Sun Mar 12 13:26:30 2000 Greg J. Badros * struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes. 2000-03-12 Marius Vollmer - + * 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 * coop-defs.h (struct timespec): Conditionally defined. @@ -383,14 +405,14 @@ Sun Mar 12 13:26:30 2000 Greg J. Badros 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 (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 Thu Mar 9 11:33:25 2000 Greg J. Badros - * 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 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 * 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 Thu Mar 2 12:38:30 2000 Greg J. Badros - * 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 * 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 Sun Feb 13 19:11:42 2000 Greg J. Badros * 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 * strings.h: don't use SCM_P. don't include . * error.c, gh_data.c, ports.c, script.c, strop.c: include . - + * 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 "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 * vectors.c, symbols.c, strorder.c: Documentation cut and pasted @@ -624,13 +646,13 @@ Wed Jan 26 17:33:52 2000 Greg J. Badros Wed Jan 26 10:02:11 2000 Greg J. Badros - * 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 * 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 * random.c: Added documentation, from SLIB page: @@ -666,7 +688,7 @@ Mon Jan 24 17:50:20 2000 Greg J. Badros 2000-01-23 Gary Houston - * 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 @@ -713,7 +735,7 @@ Tue Jan 18 13:21:08 2000 Mikael Djurfeldt 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 * 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 * 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 @@ -852,7 +874,7 @@ Tue Jan 11 10:41:46 2000 Greg J. Badros * 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 * 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 * 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 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 * 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 Thu Jan 6 11:21:49 2000 Greg J. Badros - * 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 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 Wed Jan 5 08:36:38 2000 Greg J. Badros * 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 @@ -1083,7 +1105,7 @@ Tue Jan 4 14:21:35 2000 Greg J. Badros Mon Jan 3 08:30:02 2000 Greg Harvey (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. diff --git a/libguile/gc.c b/libguile/gc.c index dbd5d278b..806f19ae0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -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; - - size = (size / sizeof (scm_cell) / span) * span * sizeof (scm_cell); + ptr = CELL_UP (seg_org, span); - /* 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 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 +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; diff --git a/libguile/gc.h b/libguile/gc.h index 72d697eeb..cb64d7d18 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -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); diff --git a/libguile/tags.h b/libguile/tags.h index dc19d0e0f..5288bd3ff 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -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. */ -- 2.20.1