diff options
70 files changed, 1463 insertions, 5569 deletions
diff --git a/configure.in b/configure.in index e67e1d84a..817a1e5b5 100644 --- a/configure.in +++ b/configure.in @@ -1177,6 +1177,18 @@ main () [], [AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)]) +#-------------------------------------------------------------------- +# +# Boehm's GC library +# +#-------------------------------------------------------------------- +AC_CHECK_LIB([gc], [GC_collect_a_little], + [LIBS="-lgc $LIBS"], + [AC_MSG_ERROR([`libgc' (Boehm's GC library) not found.])]) +AC_CHECK_HEADER([gc/gc.h], [], + [AC_MSG_ERROR([`libgc' (Boehm's GC library) header files not found.])]) + + AC_CHECK_SIZEOF(float) if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then AC_DEFINE(SCM_SINGLES, 1, diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 6ada33c68..5a74f945f 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1223,6 +1223,8 @@ ;; We can't pass this as an argument to module-constructor, ;; because we need it to close over a pointer to the module ;; itself. + ;; FIXME: This creates a circular reference between MODULE and its + ;; standard eval closure which precludes them from being collected. (set-module-eval-closure! module (standard-eval-closure module)) module)))) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 579ae89a2..0687c03a2 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -109,9 +109,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \ chars.c continuations.c convert.c debug.c deprecation.c \ deprecated.c discouraged.c dynwind.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ - futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ - gc-freelist.c gc_os_dep.c gdbint.c gettext.c gc-segment-table.c \ - gh_data.c gh_eval.c gh_funcs.c \ + futures.c gc.c gc-malloc.c \ + gdbint.c gettext.c gh_data.c gh_eval.c gh_funcs.c \ gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \ guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ @@ -134,10 +133,9 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ - dynl.x dynwind.x eq.x error.x eval.x evalext.x \ - extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ - gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \ - gsubr.x guardians.x gc-segment-table.x \ + dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ + extensions.x feature.x fluids.x fports.x futures.x gc.x \ + gettext.c goops.x gsubr.x guardians.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ @@ -154,9 +152,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \ deprecated.doc discouraged.doc dynl.doc dynwind.doc \ eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ - gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \ - gc-malloc.doc gc-card.doc gettext.doc gc-segment-table.doc \ - guardians.doc hash.doc hashtab.doc \ + gc.doc goops.doc gsubr.doc \ + gc-malloc.doc gettext.doc guardians.doc hash.doc hashtab.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ @@ -210,6 +207,7 @@ pkginclude_HEADERS = gh.h # These are headers visible as <libguile/mumble.h>. modincludedir = $(includedir)/libguile modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \ + boehm-gc.h \ boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \ deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ eq.h error.h eval.h evalext.h extensions.h \ diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 57c089778..a3ecb75eb 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -155,7 +155,6 @@ void scm_init_arbiters () { scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0); - scm_set_smob_mark (scm_tc16_arbiter, scm_markcdr); scm_set_smob_print (scm_tc16_arbiter, arbiter_print); #include "libguile/arbiters.x" } diff --git a/libguile/async.c b/libguile/async.c index b3209be9a..2833b5473 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -86,11 +86,6 @@ static scm_t_bits tc16_async; #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 ((X), SCM_TYP16 (X) | ((V) << 16))) #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X) -static SCM -async_gc_mark (SCM obj) -{ - return ASYNC_THUNK (obj); -} SCM_DEFINE (scm_async, "async", 1, 0, 0, (SCM thunk), @@ -480,7 +475,6 @@ scm_init_async () { scm_asyncs = SCM_EOL; tc16_async = scm_make_smob_type ("async", 0); - scm_set_smob_mark (tc16_async, async_gc_mark); #include "libguile/async.x" } diff --git a/libguile/boehm-gc.h b/libguile/boehm-gc.h new file mode 100644 index 000000000..49a369596 --- /dev/null +++ b/libguile/boehm-gc.h @@ -0,0 +1,39 @@ +#ifndef SCM_BOEHM_GC_H +#define SCM_BOEHM_GC_H + +/* Copyright (C) 2006 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library 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 + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +/* Correct header inclusion. */ + +#include "libguile/gen-scmconfig.h" + +#ifdef SCM_I_GSC_USE_PTHREAD_THREADS + +/* When pthreads are used, let `libgc' know about it and redirect allocation + calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local + allocation. */ + +# define GC_THREADS 1 +# define GC_REDIRECT_TO_LOCAL 1 + +#endif + +#include <gc/gc.h> +#include <gc/gc_local_alloc.h> + +#endif /* SCM_BOEHM_GC_H */ diff --git a/libguile/continuations.c b/libguile/continuations.c index 80a2790b8..07c843d21 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -43,41 +43,6 @@ scm_t_bits scm_tc16_continuation; -static SCM -continuation_mark (SCM obj) -{ - scm_t_contregs *continuation = SCM_CONTREGS (obj); - - scm_gc_mark (continuation->root); - scm_gc_mark (continuation->throw_value); - scm_mark_locations (continuation->stack, continuation->num_stack_items); -#ifdef __ia64__ - if (continuation->backing_store) - scm_mark_locations (continuation->backing_store, - continuation->backing_store_size / - sizeof (SCM_STACKITEM)); -#endif /* __ia64__ */ - return continuation->dynenv; -} - -static size_t -continuation_free (SCM obj) -{ - scm_t_contregs *continuation = SCM_CONTREGS (obj); - /* stack array size is 1 if num_stack_items is 0. */ - size_t extra_items = (continuation->num_stack_items > 0) - ? (continuation->num_stack_items - 1) - : 0; - size_t bytes_free = sizeof (scm_t_contregs) - + extra_items * sizeof (SCM_STACKITEM); - -#ifdef __ia64__ - scm_gc_free (continuation->backing_store, continuation->backing_store_size, - "continuation backing store"); -#endif /* __ia64__ */ - scm_gc_free (continuation, bytes_free, "continuation"); - return 0; -} static int continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) @@ -410,8 +375,6 @@ void scm_init_continuations () { scm_tc16_continuation = scm_make_smob_type ("continuation", 0); - scm_set_smob_mark (scm_tc16_continuation, continuation_mark); - scm_set_smob_free (scm_tc16_continuation, continuation_free); scm_set_smob_print (scm_tc16_continuation, continuation_print); scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1); #include "libguile/continuations.x" diff --git a/libguile/coop-pthreads.c b/libguile/coop-pthreads.c index b1759f9ed..641583037 100644 --- a/libguile/coop-pthreads.c +++ b/libguile/coop-pthreads.c @@ -31,7 +31,7 @@ #include "libguile/eval.h" #include "libguile/async.h" #include "libguile/ports.h" -#include "libguile/gc.h" +#include "libguile/smob.h" #undef DEBUG @@ -101,7 +101,8 @@ make_thread (SCM creation_protects) { SCM z; scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread"); - z = scm_cell (scm_tc16_thread, (scm_t_bits)t); + + SCM_NEWSMOB (z, t); t->handle = z; t->result = creation_protects; t->base = NULL; @@ -129,15 +130,6 @@ init_thread_creatant (SCM thread, SCM_STACKITEM *base) t->top = NULL; } -static SCM -thread_mark (SCM obj) -{ - scm_copt_thread *t = SCM_THREAD_DATA (obj); - scm_gc_mark (t->result); - scm_gc_mark (t->joining_threads); - return t->root->handle; -} - static int thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { @@ -517,7 +509,7 @@ create_thread (scm_t_catch_body body, void *body_data, /* Allocate thread locals. */ root = scm_make_root (scm_root->handle); - data = scm_malloc (sizeof (launch_data)); + data = scm_gc_malloc (sizeof (launch_data)); /* Make thread. */ thread = make_thread (protects); @@ -596,13 +588,6 @@ typedef struct scm_copt_mutex { SCM waiting; } scm_copt_mutex; -static SCM -mutex_mark (SCM mx) -{ - scm_copt_mutex *m = SCM_MUTEX_DATA (mx); - scm_gc_mark (m->owner); - return m->waiting; -} SCM scm_make_mutex () @@ -826,13 +811,7 @@ scm_threads_init (SCM_STACKITEM *base) scm_gc_register_root (&all_threads); all_threads = scm_cons (cur_thread, SCM_EOL); - scm_set_smob_mark (scm_tc16_thread, thread_mark); scm_set_smob_print (scm_tc16_thread, thread_print); - scm_set_smob_free (scm_tc16_thread, thread_free); - - scm_set_smob_mark (scm_tc16_mutex, mutex_mark); - - scm_set_smob_mark (scm_tc16_condvar, cond_mark); } /*** Marking stacks */ @@ -855,83 +834,7 @@ scm_threads_init (SCM_STACKITEM *base) # define SCM_MARK_BACKING_STORE() #endif -void -scm_threads_mark_stacks (void) -{ - volatile SCM c; - for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c)) - { - scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c)); - if (t->base == NULL) - { - /* Not fully initialized yet. */ - continue; - } - if (t->top == NULL) - { - /* Active thread */ - /* stack_len is long rather than sizet in order to guarantee - that &stack_len is long aligned */ -#if SCM_STACK_GROWS_UP - long stack_len = ((SCM_STACKITEM *) (&t) - - (SCM_STACKITEM *) thread->base); - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the information about length and base address must - * remain usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_resizuve. - */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations (((size_t) t->base, - (sizet) stack_len)); -#else - long stack_len = ((SCM_STACKITEM *) t->base - - (SCM_STACKITEM *) (&t)); - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the information about length and base address must - * remain usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_resizuve. - */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ((size_t) sizeof scm_save_regs_gc_mark - / sizeof (SCM_STACKITEM))); - - scm_mark_locations ((SCM_STACKITEM *) &t, - stack_len); -#endif - } - else - { - /* Suspended thread */ -#if SCM_STACK_GROWS_UP - long stack_len = t->top - t->base; - scm_mark_locations (t->base, stack_len); -#else - long stack_len = t->base - t->top; - scm_mark_locations (t->top, stack_len); -#endif - scm_mark_locations ((SCM_STACKITEM *) t->regs, - ((size_t) sizeof(t->regs) - / sizeof (SCM_STACKITEM))); - } - } -} + /*** Select */ diff --git a/libguile/coop-pthreads.h b/libguile/coop-pthreads.h index cc1f75a9b..490b1e28b 100644 --- a/libguile/coop-pthreads.h +++ b/libguile/coop-pthreads.h @@ -29,6 +29,8 @@ #include <pthread.h> +#include "libguile/boehm-gc.h" + #include "libguile/iselect.h" #if (SCM_ENABLE_DEPRECATED == 1) diff --git a/libguile/coop.c b/libguile/coop.c index 133c3d470..a8dca12c5 100644 --- a/libguile/coop.c +++ b/libguile/coop.c @@ -511,6 +511,8 @@ coop_condition_variable_destroy (coop_c *c) #ifdef GUILE_PTHREAD_COMPAT +#include "libguile/boehm-gc.h" + /* 1K room for the cond wait routine */ #if SCM_STACK_GROWS_UP # define COOP_STACK_ROOM (256) diff --git a/libguile/debug.c b/libguile/debug.c index 08793f3ff..280e92b7d 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -532,7 +532,6 @@ scm_init_debug () scm_init_opts (scm_debug_options, scm_debug_opts); scm_tc16_memoized = scm_make_smob_type ("memoized", 0); - scm_set_smob_mark (scm_tc16_memoized, scm_markcdr); scm_set_smob_print (scm_tc16_memoized, memoized_print); scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0); diff --git a/libguile/dynl.c b/libguile/dynl.c index be9f6910f..a90d67eab 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -118,12 +118,6 @@ scm_t_bits scm_tc16_dynamic_obj; #define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v))) -static SCM -dynl_obj_mark (SCM ptr) -{ - return DYNL_FILENAME (ptr); -} - static int dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) @@ -313,7 +307,6 @@ void scm_init_dynamic_linking () { scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0); - scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark); scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print); sysdep_dynl_init (); #include "libguile/dynl.x" diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 82095008f..5f47ba9d9 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -186,14 +186,6 @@ scm_dynwind_end (void) assert (0); } -static SCM -winder_mark (SCM w) -{ - if (WINDER_MARK_P (w)) - return SCM_PACK (WINDER_DATA (w)); - return SCM_BOOL_F; -} - void scm_dynwind_unwind_handler (void (*proc) (void *), void *data, scm_t_wind_flags flags) @@ -371,7 +363,6 @@ scm_init_dynwind () tc16_frame = scm_make_smob_type ("frame", 0); tc16_winder = scm_make_smob_type ("winder", 0); - scm_set_smob_mark (tc16_winder, winder_mark); #include "libguile/dynwind.x" } diff --git a/libguile/environments.c b/libguile/environments.c index 5d15f36bc..ed23d3011 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -96,7 +96,7 @@ scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol) SCM scm_make_environment (void *type) { - return scm_cell (scm_tc16_environment, (scm_t_bits) type); + SCM_RETURN_NEWSMOB (scm_tc16_environment, type); } @@ -443,20 +443,6 @@ SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0, #undef FUNC_NAME -static SCM -environment_mark (SCM env) -{ - return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env); -} - - -static size_t -environment_free (SCM env) -{ - (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env); - return 0; -} - static int environment_print (SCM env, SCM port, scm_print_state *pstate) @@ -468,14 +454,6 @@ environment_print (SCM env, SCM port, scm_print_state *pstate) /* observers */ -static SCM -observer_mark (SCM observer) -{ - scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer)); - scm_gc_mark (SCM_OBSERVER_DATA (observer)); - return SCM_BOOL_F; -} - static int observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -645,10 +623,12 @@ struct core_environments_base { static SCM core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p) { - SCM observer = scm_double_cell (scm_tc16_observer, - SCM_UNPACK (env), - SCM_UNPACK (data), - (scm_t_bits) proc); + SCM observer; + + SCM_NEWSMOB3 (observer, scm_tc16_observer, + SCM_UNPACK (env), + SCM_UNPACK (data), + (scm_t_bits) proc); if (!weak_p) { @@ -719,20 +699,6 @@ core_environments_unobserve (SCM env, SCM observer) } -static SCM -core_environments_mark (SCM env) -{ - scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env)); - return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env); -} - - -static void -core_environments_finalize (SCM env SCM_UNUSED) -{ -} - - static void core_environments_preinit (struct core_environments_base *body) { @@ -962,22 +928,6 @@ leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED) } -static SCM -leaf_environment_mark (SCM env) -{ - scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray); - return core_environments_mark (env); -} - - -static void -leaf_environment_free (SCM env) -{ - core_environments_finalize (env); - scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment), - "leaf environment"); -} - static int leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -1002,8 +952,6 @@ static struct scm_environment_funcs leaf_environment_funcs = { leaf_environment_cell, core_environments_observe, core_environments_unobserve, - leaf_environment_mark, - leaf_environment_free, leaf_environment_print }; @@ -1315,29 +1263,6 @@ eval_environment_cell (SCM env, SCM sym, int for_write) #undef FUNC_NAME -static SCM -eval_environment_mark (SCM env) -{ - struct eval_environment *body = EVAL_ENVIRONMENT (env); - - scm_gc_mark (body->obarray); - scm_gc_mark (body->imported); - scm_gc_mark (body->imported_observer); - scm_gc_mark (body->local); - scm_gc_mark (body->local_observer); - - return core_environments_mark (env); -} - - -static void -eval_environment_free (SCM env) -{ - core_environments_finalize (env); - scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment), - "eval environment"); -} - static int eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -1362,8 +1287,6 @@ static struct scm_environment_funcs eval_environment_funcs = { eval_environment_cell, core_environments_observe, core_environments_unobserve, - eval_environment_mark, - eval_environment_free, eval_environment_print }; @@ -1738,24 +1661,6 @@ import_environment_cell (SCM env, SCM sym, int for_write) #undef FUNC_NAME -static SCM -import_environment_mark (SCM env) -{ - scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports); - scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers); - scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc); - return core_environments_mark (env); -} - - -static void -import_environment_free (SCM env) -{ - core_environments_finalize (env); - scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment), - "import environment"); -} - static int import_environment_print (SCM type, SCM port, @@ -1781,8 +1686,6 @@ static struct scm_environment_funcs import_environment_funcs = { import_environment_cell, core_environments_observe, core_environments_unobserve, - import_environment_mark, - import_environment_free, import_environment_print }; @@ -2040,27 +1943,6 @@ export_environment_cell (SCM env, SCM sym, int for_write) #undef FUNC_NAME -static SCM -export_environment_mark (SCM env) -{ - struct export_environment *body = EXPORT_ENVIRONMENT (env); - - scm_gc_mark (body->private); - scm_gc_mark (body->private_observer); - scm_gc_mark (body->signature); - - return core_environments_mark (env); -} - - -static void -export_environment_free (SCM env) -{ - core_environments_finalize (env); - scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment), - "export environment"); -} - static int export_environment_print (SCM type, SCM port, @@ -2086,8 +1968,6 @@ static struct scm_environment_funcs export_environment_funcs = { export_environment_cell, core_environments_observe, core_environments_unobserve, - export_environment_mark, - export_environment_free, export_environment_print }; @@ -2317,13 +2197,10 @@ scm_environments_prehistory () { /* create environment smob */ scm_tc16_environment = scm_make_smob_type ("environment", 0); - scm_set_smob_mark (scm_tc16_environment, environment_mark); - scm_set_smob_free (scm_tc16_environment, environment_free); scm_set_smob_print (scm_tc16_environment, environment_print); /* create observer smob */ scm_tc16_observer = scm_make_smob_type ("observer", 0); - scm_set_smob_mark (scm_tc16_observer, observer_mark); scm_set_smob_print (scm_tc16_observer, observer_print); /* create system environment */ diff --git a/libguile/environments.h b/libguile/environments.h index 10d42a704..2d8765a38 100644 --- a/libguile/environments.h +++ b/libguile/environments.h @@ -51,8 +51,6 @@ struct scm_environment_funcs { SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p); void (*unobserve) (SCM self, SCM token); - SCM (*mark) (SCM self); - void (*free) (SCM self); int (*print) (SCM self, SCM port, scm_print_state *pstate); }; diff --git a/libguile/eval.c b/libguile/eval.c index 218633e9d..0aec95106 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3670,18 +3670,6 @@ scm_makprom (SCM code) scm_make_recursive_mutex ()); } -static SCM -promise_mark (SCM promise) -{ - scm_gc_mark (SCM_PROMISE_MUTEX (promise)); - return SCM_PROMISE_DATA (promise); -} - -static size_t -promise_free (SCM promise) -{ - return 0; -} static int promise_print (SCM exp, SCM port, scm_print_state *pstate) @@ -4066,8 +4054,6 @@ scm_init_eval () scm_eval_opts); scm_tc16_promise = scm_make_smob_type ("promise", 0); - scm_set_smob_mark (scm_tc16_promise, promise_mark); - scm_set_smob_free (scm_tc16_promise, promise_free); scm_set_smob_print (scm_tc16_promise, promise_print); undefineds = scm_list_1 (SCM_UNDEFINED); diff --git a/libguile/fluids.c b/libguile/fluids.c index eded07472..b5334dbdb 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -133,6 +133,8 @@ scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED, void *dummy2 SCM_UNUSED, void *dummy3 SCM_UNUSED) { + /* FIXME: What to do here? */ +#if 0 SCM *statep, *fluidp; /* Scan all fluids and deallocate the unmarked ones. @@ -172,19 +174,10 @@ scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED, } } +#endif return NULL; } -static size_t -fluid_free (SCM fluid) -{ - /* The real work is done in scan_dynamic_states_and_fluids. We can - not touch allocated_fluids etc here since a smob free routine can - be run at any time, in any thread. - */ - return 0; -} - static int fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { @@ -604,11 +597,9 @@ void scm_fluids_prehistory () { tc16_fluid = scm_make_smob_type ("fluid", 0); - scm_set_smob_free (tc16_fluid, fluid_free); scm_set_smob_print (tc16_fluid, fluid_print); tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0); - scm_set_smob_mark (tc16_dynamic_state, scm_markcdr); scm_c_hook_add (&scm_after_sweep_c_hook, scan_dynamic_states_and_fluids, 0, 0); diff --git a/libguile/fports.c b/libguile/fports.c index efbd27899..bcb5a1ecf 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -119,7 +119,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size) if (SCM_INPUT_PORT_P (port) && read_size > 0) { - pt->read_buf = scm_gc_malloc (read_size, "port buffer"); + pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer"); pt->read_pos = pt->read_end = pt->read_buf; pt->read_buf_size = read_size; } @@ -131,7 +131,7 @@ scm_fport_buffer_add (SCM port, long read_size, int write_size) if (SCM_OUTPUT_PORT_P (port) && write_size > 0) { - pt->write_buf = scm_gc_malloc (write_size, "port buffer"); + pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer"); pt->write_pos = pt->write_buf; pt->write_buf_size = write_size; } @@ -456,7 +456,8 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) pt = SCM_PTAB_ENTRY(port); { scm_t_fport *fp - = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port"); + = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport), + "file port"); fp->fdes = fdes; pt->rw_random = SCM_FDES_RANDOM_P (fdes); diff --git a/libguile/futures.c b/libguile/futures.c index 5da8dfa06..df1c4616c 100644 --- a/libguile/futures.c +++ b/libguile/futures.c @@ -203,10 +203,6 @@ scm_i_make_future (SCM thunk) return future; } -static SCM -future_mark (SCM ptr) { - return SCM_FUTURE_DATA (ptr); -} static int future_print (SCM exp, SCM port, scm_print_state *pstate) @@ -359,7 +355,6 @@ scm_init_futures () = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F)); scm_tc16_future = scm_make_smob_type ("future", 0); - scm_set_smob_mark (scm_tc16_future, future_mark); scm_set_smob_print (scm_tc16_future, future_print); scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0); diff --git a/libguile/gc-card.c b/libguile/gc-card.c deleted file mode 100644 index 93e271ae6..000000000 --- a/libguile/gc-card.c +++ /dev/null @@ -1,488 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -#if HAVE_CONFIG_H -# include <config.h> -#endif - -#include <assert.h> -#include <stdio.h> -#include <count-one-bits.h> - -#include <gmp.h> - -#include "libguile/_scm.h" -#include "libguile/async.h" -#include "libguile/deprecation.h" -#include "libguile/eval.h" -#include "libguile/gc.h" -#include "libguile/hashtab.h" -#include "libguile/numbers.h" -#include "libguile/ports.h" -#include "libguile/private-gc.h" -#include "libguile/root.h" -#include "libguile/smob.h" -#include "libguile/srfi-4.h" -#include "libguile/stackchk.h" -#include "libguile/stime.h" -#include "libguile/strings.h" -#include "libguile/struct.h" -#include "libguile/tags.h" -#include "libguile/unif.h" -#include "libguile/validate.h" -#include "libguile/vectors.h" -#include "libguile/weaks.h" - -#include "libguile/private-gc.h" - -long int scm_i_deprecated_memory_return; - - -/* During collection, this accumulates structures which are to be freed. - */ -SCM scm_i_structs_to_free; - -/* - Init all the free cells in CARD, prepending to *FREE_LIST. - - Return: FREE_COUNT, the number of cells collected. This is - typically the length of the *FREE_LIST, but for some special cases, - we do not actually free the cell. To make the numbers match up, we - do increase the FREE_COUNT. - - It would be cleaner to have a separate function sweep_value (), but - that is too slow (functions with switch statements can't be - inlined). - - NOTE: - - For many types of cells, allocation and a de-allocation involves - calling malloc () and free (). This is costly for small objects (due - to malloc/free overhead.) (should measure this). - - It might also be bad for threads: if several threads are allocating - strings concurrently, then mallocs for both threads may have to - fiddle with locks. - - It might be interesting to add a separate memory pool for small - objects to each freelist. - - --hwn. - */ -int -scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg) -#define FUNC_NAME "sweep_card" -{ - scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (card); - scm_t_cell *end = card + SCM_GC_CARD_N_CELLS; - scm_t_cell *p = card; - int span = seg->span; - int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span); - int free_count = 0; - - /* - I tried something fancy with shifting by one bit every word from - the bitvec in turn, but it wasn't any faster, but quite a bit - hairier. - */ - for (p += offset; p < end; p += span, offset += span) - { - SCM scmptr = PTR2SCM (p); - if (SCM_C_BVEC_GET (bitvec, offset)) - continue; - free_count++; - switch (SCM_TYP7 (scmptr)) - { - case scm_tcs_struct: - /* The card can be swept more than once. Check that it's - * the first time! - */ - if (!SCM_STRUCT_GC_CHAIN (scmptr)) - { - /* Structs need to be freed in a special order. - * This is handled by GC C hooks in struct.c. - */ - SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free); - scm_i_structs_to_free = scmptr; - } - continue; - - case scm_tcs_cons_imcar: - case scm_tcs_cons_nimcar: - case scm_tcs_closures: - case scm_tc7_pws: - break; - case scm_tc7_wvect: - case scm_tc7_vector: - scm_i_vector_free (scmptr); - break; - -#ifdef CCLO - case scm_tc7_cclo: - scm_gc_free (SCM_CCLO_BASE (scmptr), - SCM_CCLO_LENGTH (scmptr) * sizeof (SCM), - "compiled closure"); - break; -#endif - - case scm_tc7_number: - switch SCM_TYP16 (scmptr) - { - case scm_tc16_real: - break; - case scm_tc16_big: - mpz_clear (SCM_I_BIG_MPZ (scmptr)); - /* nothing else to do here since the mpz is in a double cell */ - break; - case scm_tc16_complex: - scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex), - "complex"); - break; - case scm_tc16_fraction: - /* nothing to do here since the num/denum of a fraction - are proper SCM objects themselves. */ - break; - } - break; - case scm_tc7_string: - scm_i_string_free (scmptr); - break; - case scm_tc7_stringbuf: - scm_i_stringbuf_free (scmptr); - break; - case scm_tc7_symbol: - scm_i_symbol_free (scmptr); - break; - case scm_tc7_variable: - break; - case scm_tcs_subrs: - /* the various "subrs" (primitives) are never freed */ - continue; - case scm_tc7_port: - if SCM_OPENP (scmptr) - { - int k = SCM_PTOBNUM (scmptr); - size_t mm; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (!(k < scm_numptob)) - { - fprintf (stderr, "undefined port type"); - abort (); - } -#endif - /* Keep "revealed" ports alive. */ - if (scm_revealed_count (scmptr) > 0) - continue; - - /* Yes, I really do mean scm_ptobs[k].free */ - /* rather than ftobs[k].close. .close */ - /* is for explicit CLOSE-PORT by user */ - mm = scm_ptobs[k].free (scmptr); - - if (mm != 0) - { -#if SCM_ENABLE_DEPRECATED == 1 - scm_c_issue_deprecation_warning - ("Returning non-0 from a port free function is " - "deprecated. Use scm_gc_free et al instead."); - scm_c_issue_deprecation_warning_fmt - ("(You just returned non-0 while freeing a %s.)", - SCM_PTOBNAME (k)); - scm_i_deprecated_memory_return += mm; -#else - abort (); -#endif - } - - SCM_SETSTREAM (scmptr, 0); - scm_i_remove_port (scmptr); - SCM_CLR_PORT_OPEN_FLAG (scmptr); - } - break; - case scm_tc7_smob: - switch SCM_TYP16 (scmptr) - { - case scm_tc_free_cell: - break; - default: - { - int k; - k = SCM_SMOBNUM (scmptr); -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (!(k < scm_numsmob)) - { - fprintf (stderr, "undefined smob type"); - abort (); - } -#endif - if (scm_smobs[k].free) - { - size_t mm; - mm = scm_smobs[k].free (scmptr); - if (mm != 0) - { -#if SCM_ENABLE_DEPRECATED == 1 - scm_c_issue_deprecation_warning - ("Returning non-0 from a smob free function is " - "deprecated. Use scm_gc_free et al instead."); - scm_c_issue_deprecation_warning_fmt - ("(You just returned non-0 while freeing a %s.)", - SCM_SMOBNAME (k)); - scm_i_deprecated_memory_return += mm; -#else - abort (); -#endif - } - } - break; - } - } - break; - default: - fprintf (stderr, "unknown type"); - abort (); - } - - SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell); - SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list)); - *free_list = scmptr; - } - - return free_count; -} -#undef FUNC_NAME - - -/* - Like sweep, but no complicated logic to do the sweeping. - */ -int -scm_i_init_card_freelist (scm_t_cell *card, SCM *free_list, - scm_t_heap_segment *seg) -{ - int span = seg->span; - scm_t_cell *end = card + SCM_GC_CARD_N_CELLS; - scm_t_cell *p = end - span; - int collected = 0; - scm_t_c_bvec_long *bvec_ptr = (scm_t_c_bvec_long*) seg->bounds[1]; - int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; - - bvec_ptr += idx * SCM_GC_CARD_BVEC_SIZE_IN_LONGS; - SCM_GC_SET_CELL_BVEC (card, bvec_ptr); - - /* - ASSUMPTION: n_header_cells <= 2. - */ - for (; p > card; p -= span) - { - const SCM scmptr = PTR2SCM (p); - SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell); - SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list)); - *free_list = scmptr; - collected ++; - } - - return collected; -} - -/* - Amount of cells marked in this cell, measured in 1-cells. - */ -int -scm_i_card_marked_count (scm_t_cell *card, int span) -{ - scm_t_c_bvec_long* bvec = SCM_GC_CARD_BVEC (card); - scm_t_c_bvec_long* bvec_end = (bvec + SCM_GC_CARD_BVEC_SIZE_IN_LONGS); - - int count = 0; - while (bvec < bvec_end) - { - count += count_one_bits_l (*bvec); - bvec ++; - } - return count * span; -} - -void -scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg) -{ - scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC (p); - scm_t_cell * end = p + SCM_GC_CARD_N_CELLS; - int span = seg->span; - int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span); - - if (!bitvec) - /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */ - return; - - for (p += offset; p < end; p += span, offset += span) - { - scm_t_bits tag = -1; - SCM scmptr = PTR2SCM (p); - - if (!SCM_C_BVEC_GET (bitvec, offset)) - continue; - - tag = SCM_TYP7 (scmptr); - if (tag == scm_tc7_smob || tag == scm_tc7_number) - { - /* Record smobs and numbers under 16 bits of the tag, so the - different smob objects are distinguished, and likewise the - different numbers big, real, complex and fraction. */ - tag = SCM_TYP16(scmptr); - } - else - switch (tag) - { - case scm_tcs_cons_imcar: - tag = scm_tc2_int; - break; - case scm_tcs_cons_nimcar: - tag = scm_tc3_cons; - break; - - case scm_tcs_struct: - tag = scm_tc3_struct; - break; - case scm_tcs_closures: - tag = scm_tc3_closure; - break; - case scm_tcs_subrs: - tag = scm_tc7_asubr; - break; - } - - { - SCM handle = scm_hashq_create_handle_x (hashtab, - scm_from_int (tag), SCM_INUM0); - SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1)); - } - } -} - -/* TAG is the tag word of a cell, return a string which is its name, or NULL - if unknown. Currently this is only used by gc-live-object-stats and the - distinctions between types are oriented towards what that code records - while scanning what's alive. */ -char const * -scm_i_tag_name (scm_t_bits tag) -{ - switch (tag & 0x7F) /* 7 bits */ - { - case scm_tcs_struct: - return "struct"; - case scm_tcs_cons_imcar: - return "cons (immediate car)"; - case scm_tcs_cons_nimcar: - return "cons (non-immediate car)"; - case scm_tcs_closures: - return "closures"; - case scm_tc7_pws: - return "pws"; - case scm_tc7_wvect: - return "weak vector"; - case scm_tc7_vector: - return "vector"; -#ifdef CCLO - case scm_tc7_cclo: - return "compiled closure"; -#endif - case scm_tc7_number: - switch (tag) - { - case scm_tc16_real: - return "real"; - case scm_tc16_big: - return "bignum"; - case scm_tc16_complex: - return "complex number"; - case scm_tc16_fraction: - return "fraction"; - } - /* shouldn't reach here unless there's a new class of numbers */ - return "number"; - case scm_tc7_string: - return "string"; - case scm_tc7_stringbuf: - return "string buffer"; - case scm_tc7_symbol: - return "symbol"; - case scm_tc7_variable: - return "variable"; - case scm_tcs_subrs: - return "subrs"; - case scm_tc7_port: - return "port"; - case scm_tc7_smob: - /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[] - entry should be ok for our return here */ - return scm_smobs[SCM_TC2SMOBNUM (tag)].name; - } - - return NULL; -} - - -#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1) - -typedef struct scm_dbg_t_list_cell { - scm_t_bits car; - struct scm_dbg_t_list_cell * cdr; -} scm_dbg_t_list_cell; - - -typedef struct scm_dbg_t_double_cell { - scm_t_bits word_0; - scm_t_bits word_1; - scm_t_bits word_2; - scm_t_bits word_3; -} scm_dbg_t_double_cell; - - -int scm_dbg_gc_marked_p (SCM obj); -scm_t_cell * scm_dbg_gc_get_card (SCM obj); -scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj); - - -int -scm_dbg_gc_marked_p (SCM obj) -{ - if (!SCM_IMP (obj)) - return SCM_GC_MARK_P (obj); - else - return 0; -} - -scm_t_cell * -scm_dbg_gc_get_card (SCM obj) -{ - if (!SCM_IMP (obj)) - return SCM_GC_CELL_CARD (obj); - else - return NULL; -} - -scm_t_c_bvec_long * -scm_dbg_gc_get_bvec (SCM obj) -{ - if (!SCM_IMP (obj)) - return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj)); - else - return NULL; -} - -#endif diff --git a/libguile/gc-freelist.c b/libguile/gc-freelist.c deleted file mode 100644 index 861af5765..000000000 --- a/libguile/gc-freelist.c +++ /dev/null @@ -1,186 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -#include <assert.h> -#include <stdio.h> - -#include "libguile/private-gc.h" -#include "libguile/gc.h" -#include "libguile/deprecation.h" -#include "libguile/private-gc.h" - -scm_t_cell_type_statistics scm_i_master_freelist; -scm_t_cell_type_statistics scm_i_master_freelist2; - -/* - -In older versions of GUILE GC there was extensive support for -debugging freelists. This was useful, since the freelist was kept -inside the heap, and writing to an object that was GC'd would mangle -the list. Mark bits are now separate, and checking for sane cell -access can be done much more easily by simply checking if the mark bit -is unset before allocation. --hwn - -*/ - -#if (SCM_ENABLE_DEPRECATED == 1) -#if defined(GUILE_DEBUG_FREELIST) - -SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0, - (), - "DEPRECATED\n") -#define FUNC_NAME "s_scm_map_free_list" -{ - scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n"); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0, - (SCM flag), - "DEPRECATED.\n") -#define FUNC_NAME "s_scm_gc_set_debug_check_freelist_x" -{ - scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n"); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -#endif /* defined (GUILE_DEBUG) */ -#endif /* deprecated */ - -static void -scm_init_freelist (scm_t_cell_type_statistics *freelist, - int span, - int min_yield_percentage) -{ - if (min_yield_percentage < 1) - min_yield_percentage = 1; - if (min_yield_percentage > 99) - min_yield_percentage = 99; - - freelist->heap_segment_idx = -1; - freelist->min_yield_fraction = min_yield_percentage / 100.0; - freelist->span = span; - freelist->swept = 0; - freelist->collected = 0; - freelist->heap_total_cells = 0; -} - -#if (SCM_ENABLE_DEPRECATED == 1) -size_t scm_default_init_heap_size_1; -int scm_default_min_yield_1; -size_t scm_default_init_heap_size_2; -int scm_default_min_yield_2; -size_t scm_default_max_segment_size; - -static void -check_deprecated_heap_vars (void) { - if (scm_default_init_heap_size_1 || - scm_default_min_yield_1|| - scm_default_init_heap_size_2|| - scm_default_min_yield_2|| - scm_default_max_segment_size) - { - scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead."); - } -} -#else -static void check_deprecated_heap_vars (void) { } -#endif - -void -scm_gc_init_freelist (void) -{ - const char *error_message = - "Could not allocate initial heap of %uld.\n" - "Try adjusting GUILE_INIT_SEGMENT_SIZE_%d\n"; - - int init_heap_size_1 - = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1); - int init_heap_size_2 - = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2); - - scm_init_freelist (&scm_i_master_freelist2, 2, - scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2)); - scm_init_freelist (&scm_i_master_freelist, 1, - scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1)); - - scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE); - - if (scm_max_segment_size <= 0) - scm_max_segment_size = SCM_DEFAULT_MAX_SEGMENT_SIZE; - - if (scm_i_get_new_heap_segment (&scm_i_master_freelist, - init_heap_size_1, return_on_error) == -1) { - fprintf (stderr, error_message, init_heap_size_1, 1); - abort (); - } - if (scm_i_get_new_heap_segment (&scm_i_master_freelist2, - init_heap_size_2, return_on_error) == -1) { - fprintf (stderr, error_message, init_heap_size_2, 2); - abort (); - } - - check_deprecated_heap_vars (); -} - - - -void -scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist) -{ - freelist->collected = 0; - freelist->swept = 0; - /* - at the end we simply start with the lowest segment again. - */ - freelist->heap_segment_idx = -1; -} - - -/* - Returns how many more cells we should allocate according to our - policy. May return negative if we don't need to allocate more. - - - The new yield should at least equal gc fraction of new heap size, i.e. - - c + dh > f * (h + dh) - - c : collected - f : min yield fraction - h : heap size - dh : size of new heap segment - - this gives dh > (f * h - c) / (1 - f). -*/ -float -scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist) -{ - float f = freelist->min_yield_fraction; - float collected = freelist->collected; - float swept = freelist->swept; - float delta = ((f * swept - collected) / (1.0 - f)); - - assert (freelist->heap_total_cells >= freelist->collected); - assert (freelist->swept == freelist->heap_total_cells); - assert (swept >= collected); - - return delta; -} diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 2f6ea21d8..a82ebe6be 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -110,23 +110,9 @@ scm_realloc (void *mem, size_t size) if (ptr) return ptr; - scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); - scm_gc_running_p = 1; + /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */ + GC_gcollect (); - scm_i_gc ("realloc"); - - /* - We don't want these sweep statistics to influence results for - cell GC, so we don't collect statistics. - - realloc () failed, so we're really desparate to free memory. Run a - full sweep. - */ - scm_i_sweep_all_segments ("realloc", NULL); - - scm_gc_running_p = 0; - scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); - SCM_SYSCALL (ptr = realloc (mem, size)); if (ptr) return ptr; @@ -156,7 +142,7 @@ scm_calloc (size_t sz) SCM_SYSCALL (ptr = calloc (sz, 1)); if (ptr) return ptr; - + ptr = scm_realloc (NULL, sz); memset (ptr, 0x0, sz); return ptr; @@ -178,119 +164,15 @@ scm_strdup (const char *str) return scm_strndup (str, strlen (str)); } -static void -decrease_mtrigger (size_t size, const char * what) -{ - scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex); - if (size > scm_mallocated) - { - fprintf (stderr, "`scm_mallocated' underflow. This means that more " - "memory was unregistered\n" - "via `scm_gc_unregister_collectable_memory ()' than " - "registered.\n"); - abort (); - } - - scm_mallocated -= size; - scm_gc_malloc_collected += size; - scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex); -} - -static void -increase_mtrigger (size_t size, const char *what) -{ - size_t mallocated = 0; - int overflow = 0, triggered = 0; - - scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex); - if (ULONG_MAX - size < scm_mallocated) - overflow = 1; - else - { - scm_mallocated += size; - mallocated = scm_mallocated; - if (scm_mallocated > scm_mtrigger) - triggered = 1; - } - scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex); - - if (overflow) - scm_memory_error ("Overflow of scm_mallocated: too much memory in use."); - - /* - A program that uses a lot of malloced collectable memory (vectors, - strings), will use a lot of memory off the cell-heap; it needs to - do GC more often (before cells are exhausted), otherwise swapping - and malloc management will tie it down. - */ - if (triggered) - { - unsigned long prev_alloced; - float yield; - - scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); - scm_gc_running_p = 1; - - prev_alloced = mallocated; - - /* The GC will finish the pending sweep. For that reason, we - don't execute a complete sweep after GC, although that might - free some more memory. - */ - scm_i_gc (what); - - yield = (((float) prev_alloced - (float) scm_mallocated) - / (float) prev_alloced); - - scm_gc_malloc_yield_percentage = (int) (100 * yield); - -#ifdef DEBUGINFO - fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d", - prev_alloced, - scm_mallocated, - 100.0 * yield, - scm_i_minyield_malloc); -#endif - - if (yield < scm_i_minyield_malloc / 100.0) - { - /* - We make the trigger a little larger, even; If you have a - program that builds up a lot of data in strings, then the - desired yield will never be satisfied. - - Instead of getting bogged down, we let the mtrigger grow - strongly with it. - */ - float no_overflow_trigger = scm_mallocated * 110.0; - - no_overflow_trigger /= (float) (100.0 - scm_i_minyield_malloc); - - - if (no_overflow_trigger >= (float) ULONG_MAX) - scm_mtrigger = ULONG_MAX; - else - scm_mtrigger = (unsigned long) no_overflow_trigger; - -#ifdef DEBUGINFO - fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n", - scm_mtrigger); -#endif - } - - scm_gc_running_p = 0; - scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); - } -} void scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) { - increase_mtrigger (size, what); + /* Nothing to do. */ #ifdef GUILE_DEBUG_MALLOC if (mem) - scm_malloc_register (mem, what); + scm_malloc_register (mem); #endif } @@ -298,13 +180,21 @@ scm_gc_register_collectable_memory (void *mem, size_t size, const char *what) void scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what) { - decrease_mtrigger (size, what); + /* Nothing to do. */ #ifdef GUILE_DEBUG_MALLOC if (mem) scm_malloc_unregister (mem); #endif } +/* Allocate SIZE bytes of memory whose contents should not be scanned for + pointers (useful, e.g., for strings). */ +void * +scm_gc_malloc_pointerless (size_t size, const char *what) +{ + return GC_MALLOC_ATOMIC (size); +} + void * scm_gc_malloc (size_t size, const char *what) { @@ -319,8 +209,14 @@ scm_gc_malloc (size_t size, const char *what) to write it the program is killed with signal 11. --hwn */ - void *ptr = size ? scm_malloc (size) : NULL; - scm_gc_register_collectable_memory (ptr, size, what); + void *ptr; + + if (size == 0) + /* `GC_MALLOC ()' doesn't handle zero. */ + size = sizeof (void *); + + ptr = GC_MALLOC (size); + return ptr; } @@ -338,26 +234,13 @@ scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what) { void *ptr; - /* XXX - see scm_gc_malloc. */ - - - /* - scm_realloc () may invalidate the block pointed to by WHERE, eg. by - unmapping it from memory or altering the contents. Since - increase_mtrigger () might trigger a GC that would scan - MEM, it is crucial that this call precedes realloc (). - */ - - decrease_mtrigger (old_size, what); - increase_mtrigger (new_size, what); - - ptr = scm_realloc (mem, new_size); + ptr = GC_REALLOC (mem, new_size); #ifdef GUILE_DEBUG_MALLOC if (mem) scm_malloc_reregister (mem, ptr, what); #endif - + return ptr; } @@ -365,14 +248,13 @@ void scm_gc_free (void *mem, size_t size, const char *what) { scm_gc_unregister_collectable_memory (mem, size, what); - if (mem) - free (mem); + GC_FREE (mem); } char * scm_gc_strndup (const char *str, size_t n, const char *what) { - char *dst = scm_gc_malloc (n+1, what); + char *dst = GC_MALLOC (n+1); memcpy (dst, str, n); dst[n] = 0; return dst; diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c deleted file mode 100644 index c334c1075..000000000 --- a/libguile/gc-mark.c +++ /dev/null @@ -1,520 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - - - -#if HAVE_CONFIG_H -# include <config.h> -#endif - -#include <stdio.h> -#include <errno.h> -#include <string.h> -#include <assert.h> - -#ifdef __ia64__ -#include <ucontext.h> -extern unsigned long * __libc_ia64_register_backing_store_base; -#endif - -#include "libguile/_scm.h" -#include "libguile/eval.h" -#include "libguile/stime.h" -#include "libguile/stackchk.h" -#include "libguile/struct.h" -#include "libguile/smob.h" -#include "libguile/unif.h" -#include "libguile/async.h" -#include "libguile/ports.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/weaks.h" -#include "libguile/hashtab.h" -#include "libguile/tags.h" -#include "libguile/private-gc.h" -#include "libguile/validate.h" -#include "libguile/deprecation.h" -#include "libguile/gc.h" -#include "libguile/guardians.h" - -#ifdef GUILE_DEBUG_MALLOC -#include "libguile/debug-malloc.h" -#endif - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -/* - Entry point for this file. - */ -void -scm_mark_all (void) -{ - long j; - int loops; - - scm_i_marking = 1; - scm_i_init_weak_vectors_for_gc (); - scm_i_init_guardians_for_gc (); - - scm_i_clear_mark_space (); - scm_i_find_heap_calls = 0; - /* Mark every thread's stack and registers */ - scm_threads_mark_stacks (); - - j = SCM_NUM_PROTECTS; - while (j--) - scm_gc_mark (scm_sys_protects[j]); - - /* mark the registered roots */ - { - size_t i; - for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i) - { - SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i); - for (; !scm_is_null (l); l = SCM_CDR (l)) - { - SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l))); - scm_gc_mark (*p); - } - } - } - - scm_mark_subr_table (); - - loops = 0; - while (1) - { - int again; - loops++; - - /* Mark the non-weak references of weak vectors. For a weak key - alist vector, this would mark the values for keys that are - marked. We need to do this in a loop until everything - settles down since the newly marked values might be keys in - other weak key alist vectors, for example. - */ - again = scm_i_mark_weak_vectors_non_weaks (); - if (again) - continue; - - /* Now we scan all marked guardians and move all unmarked objects - from the accessible to the inaccessible list. - */ - scm_i_identify_inaccessible_guardeds (); - - /* When we have identified all inaccessible objects, we can mark - them. - */ - again = scm_i_mark_inaccessible_guardeds (); - - /* This marking might have changed the situation for weak vectors - and might have turned up new guardians that need to be processed, - so we do it all over again. - */ - if (again) - continue; - - /* Nothing new marked in this round, we are done. - */ - break; - } - - /* Remove all unmarked entries from the weak vectors. - */ - scm_i_remove_weaks_from_weak_vectors (); - - /* Bring hashtables upto date. - */ - scm_i_scan_weak_hashtables (); - scm_i_marking = 0; -} - -/* {Mark/Sweep} - */ - -/* - Mark an object precisely, then recurse. - */ -void -scm_gc_mark (SCM ptr) -{ - if (SCM_IMP (ptr)) - return; - - if (SCM_GC_MARK_P (ptr)) - return; - - if (!scm_i_marking) - { - static const char msg[] - = "Should only call scm_gc_mark() during GC."; - scm_c_issue_deprecation_warning (msg); - } - - SCM_SET_GC_MARK (ptr); - scm_gc_mark_dependencies (ptr); -} - -void -scm_i_ensure_marking (void) -{ - assert (scm_i_marking); -} - -/* - -Mark the dependencies of an object. - -Prefetching: - -Should prefetch objects before marking, i.e. if marking a cell, we -should prefetch the car, and then mark the cdr. This will improve CPU -cache misses, because the car is more likely to be in cache when we -finish the cdr. - -See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing -garbage collector cache misses. - -Prefetch is supported on GCC >= 3.1 - -(Some time later.) - -Tried this with GCC 3.1.1 -- the time differences are barely measurable. -Perhaps this would work better with an explicit markstack? - - -*/ - -void -scm_gc_mark_dependencies (SCM p) -#define FUNC_NAME "scm_gc_mark_dependencies" -{ - register long i; - register SCM ptr; - SCM cell_type; - - ptr = p; - scm_mark_dependencies_again: - - cell_type = SCM_GC_CELL_TYPE (ptr); - switch (SCM_ITAG7 (cell_type)) - { - case scm_tcs_cons_nimcar: - if (SCM_IMP (SCM_CDR (ptr))) - { - ptr = SCM_CAR (ptr); - goto gc_mark_nimp; - } - - - scm_gc_mark (SCM_CAR (ptr)); - ptr = SCM_CDR (ptr); - goto gc_mark_nimp; - case scm_tcs_cons_imcar: - ptr = SCM_CDR (ptr); - goto gc_mark_loop; - case scm_tc7_pws: - - scm_gc_mark (SCM_SETTER (ptr)); - ptr = SCM_PROCEDURE (ptr); - goto gc_mark_loop; - case scm_tcs_struct: - { - /* XXX - use less explicit code. */ - scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct; - scm_t_bits * vtable_data = (scm_t_bits *) word0; - SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]); - long len = scm_i_symbol_length (layout); - const char *fields_desc = scm_i_symbol_chars (layout); - scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr); - - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) - { - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure])); - scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter])); - } - if (len) - { - long x; - - for (x = 0; x < len - 2; x += 2, ++struct_data) - if (fields_desc[x] == 'p') - scm_gc_mark (SCM_PACK (*struct_data)); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *struct_data++; x; --x, ++struct_data) - scm_gc_mark (SCM_PACK (*struct_data)); - else - scm_gc_mark (SCM_PACK (*struct_data)); - } - } - /* mark vtable */ - ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]); - goto gc_mark_loop; - } - break; - case scm_tcs_closures: - if (SCM_IMP (SCM_ENV (ptr))) - { - ptr = SCM_CLOSCAR (ptr); - goto gc_mark_nimp; - } - scm_gc_mark (SCM_CLOSCAR (ptr)); - ptr = SCM_ENV (ptr); - goto gc_mark_nimp; - case scm_tc7_vector: - i = SCM_SIMPLE_VECTOR_LENGTH (ptr); - if (i == 0) - break; - while (--i > 0) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i); - if (SCM_NIMP (elt)) - scm_gc_mark (elt); - } - ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0); - goto gc_mark_loop; -#ifdef CCLO - case scm_tc7_cclo: - { - size_t i = SCM_CCLO_LENGTH (ptr); - size_t j; - for (j = 1; j != i; ++j) - { - SCM obj = SCM_CCLO_REF (ptr, j); - if (!SCM_IMP (obj)) - scm_gc_mark (obj); - } - ptr = SCM_CCLO_REF (ptr, 0); - goto gc_mark_loop; - } -#endif - - case scm_tc7_string: - ptr = scm_i_string_mark (ptr); - goto gc_mark_loop; - case scm_tc7_stringbuf: - ptr = scm_i_stringbuf_mark (ptr); - goto gc_mark_loop; - - case scm_tc7_number: - if (SCM_TYP16 (ptr) == scm_tc16_fraction) - { - scm_gc_mark (SCM_CELL_OBJECT_1 (ptr)); - ptr = SCM_CELL_OBJECT_2 (ptr); - goto gc_mark_loop; - } - break; - - case scm_tc7_wvect: - scm_i_mark_weak_vector (ptr); - break; - - case scm_tc7_symbol: - ptr = scm_i_symbol_mark (ptr); - goto gc_mark_loop; - case scm_tc7_variable: - ptr = SCM_CELL_OBJECT_1 (ptr); - goto gc_mark_loop; - case scm_tcs_subrs: - break; - case scm_tc7_port: - i = SCM_PTOBNUM (ptr); -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (!(i < scm_numptob)) - { - fprintf (stderr, "undefined port type"); - abort (); - } -#endif - if (SCM_PTAB_ENTRY (ptr)) - scm_gc_mark (SCM_FILENAME (ptr)); - if (scm_ptobs[i].mark) - { - ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; - } - else - return; - break; - case scm_tc7_smob: - switch (SCM_TYP16 (ptr)) - { /* should be faster than going through scm_smobs */ - case scm_tc_free_cell: - /* We have detected a free cell. This can happen if non-object data - * on the C stack points into guile's heap and is scanned during - * conservative marking. */ - break; - default: - i = SCM_SMOBNUM (ptr); -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (!(i < scm_numsmob)) - { - fprintf (stderr, "undefined smob type"); - abort (); - } -#endif - if (scm_smobs[i].mark) - { - ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; - } - else - return; - } - break; - default: - fprintf (stderr, "unknown type"); - abort (); - } - - /* - If we got here, then exhausted recursion options for PTR. we - return (careful not to mark PTR, it might be the argument that we - were called with.) - */ - return ; - - gc_mark_loop: - if (SCM_IMP (ptr)) - return; - - gc_mark_nimp: - { - int valid_cell = CELL_P (ptr); - - -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_debug_cell_accesses_p) - { - /* We are in debug mode. Check the ptr exhaustively. */ - - valid_cell = valid_cell && scm_in_heap_p (ptr); - } - -#endif - if (!valid_cell) - { - fprintf (stderr, "rogue pointer in heap"); - abort (); - } - } - - if (SCM_GC_MARK_P (ptr)) - return; - - SCM_SET_GC_MARK (ptr); - - goto scm_mark_dependencies_again; - -} -#undef FUNC_NAME - - -/* Mark a region conservatively */ -void -scm_mark_locations (SCM_STACKITEM x[], unsigned long n) -{ - unsigned long m; - - for (m = 0; m < n; ++m) - { - SCM obj = * (SCM *) &x[m]; - long int segment = scm_i_find_heap_segment_containing_object (obj); - if (segment >= 0) - scm_gc_mark (obj); - } -} - - -/* The function scm_in_heap_p determines whether an SCM value can be regarded as a - * pointer to a cell on the heap. - */ -int -scm_in_heap_p (SCM value) -{ - long int segment = scm_i_find_heap_segment_containing_object (value); - return (segment >= 0); -} - - -#if SCM_ENABLE_DEPRECATED == 1 - -/* If an allocated cell is detected during garbage collection, this - * means that some code has just obtained the object but was preempted - * before the initialization of the object was completed. This meanst - * that some entries of the allocated cell may already contain SCM - * objects. Therefore, allocated cells are scanned conservatively. - */ - -scm_t_bits scm_tc16_allocated; - -static SCM -allocated_mark (SCM cell) -{ - unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell); - unsigned int span = scm_i_heap_segment_table[cell_segment]->span; - unsigned int i; - - for (i = 1; i != span * 2; ++i) - { - SCM obj = SCM_CELL_OBJECT (cell, i); - long int obj_segment = scm_i_find_heap_segment_containing_object (obj); - if (obj_segment >= 0) - scm_gc_mark (obj); - } - return SCM_BOOL_F; -} - -SCM -scm_deprecated_newcell (void) -{ - scm_c_issue_deprecation_warning - ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n"); - - return scm_cell (scm_tc16_allocated, 0); -} - -SCM -scm_deprecated_newcell2 (void) -{ - scm_c_issue_deprecation_warning - ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n"); - - return scm_double_cell (scm_tc16_allocated, 0, 0, 0); -} - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - - -void -scm_gc_init_mark (void) -{ -#if SCM_ENABLE_DEPRECATED == 1 - scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0); - scm_set_smob_mark (scm_tc16_allocated, allocated_mark); -#endif -} - diff --git a/libguile/gc-segment.c b/libguile/gc-segment.c deleted file mode 100644 index f53ec9675..000000000 --- a/libguile/gc-segment.c +++ /dev/null @@ -1,279 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -#if HAVE_CONFIG_H -# include <config.h> -#endif - -#include <assert.h> -#include <stdio.h> -#include <string.h> - -#include <count-one-bits.h> - -#include "libguile/_scm.h" -#include "libguile/pairs.h" -#include "libguile/gc.h" -#include "libguile/private-gc.h" - -size_t scm_max_segment_size; - -/* Important entry point: try to grab some memory, and make it into a - segment; return the index of the segment. SWEEP_STATS should contain - global GC sweep statistics collected since the last full GC. - - Returns the index of the segment. If error_policy != - abort_on_error, we return -1 on failure. -*/ -int -scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, - size_t len, - policy_on_error error_policy) -{ - if (len > scm_max_segment_size) - len = scm_max_segment_size; - - if (len < SCM_MIN_HEAP_SEG_SIZE) - len = SCM_MIN_HEAP_SEG_SIZE; - - /* todo: consider having a more flexible lower bound. */ - { - scm_t_heap_segment *seg = scm_i_make_empty_heap_segment (freelist); - - /* Allocate with decaying ambition. */ - while (len >= SCM_MIN_HEAP_SEG_SIZE) - { - if (scm_i_initialize_heap_segment_data (seg, len)) - return scm_i_insert_segment (seg); - - len /= 2; - } - } - - if (error_policy == abort_on_error) - { - fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n"); - abort (); - } - return -1; -} - - -scm_t_heap_segment * -scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl) -{ - scm_t_heap_segment *shs = calloc (1, sizeof (scm_t_heap_segment)); - - if (!shs) - { - fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n"); - abort (); - } - - shs->span = fl->span; - shs->freelist = fl; - - return shs; -} - -void -scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab) -{ - scm_t_cell *p = seg->bounds[0]; - while (p < seg->bounds[1]) - { - scm_i_card_statistics (p, tab, seg); - p += SCM_GC_CARD_N_CELLS; - } -} - -/* - count number of marked bits, so we know how much cells are live. - */ -int -scm_i_heap_segment_marked_count (scm_t_heap_segment *seg) -{ - scm_t_c_bvec_long *bvec = (scm_t_c_bvec_long *) seg->bounds[1]; - scm_t_c_bvec_long *bvec_end = - (bvec + - scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS); - - int count = 0; - while (bvec < bvec_end) - { - count += count_one_bits_l (*bvec); - bvec ++; - } - return count * seg->span; -} - -int -scm_i_segment_card_number (scm_t_heap_segment *seg, - scm_t_cell *card) -{ - return (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; -} - -/* - Fill SEGMENT with memory both for data and mark bits. - - RETURN: 1 on success, 0 failure - */ -int -scm_i_initialize_heap_segment_data (scm_t_heap_segment *segment, size_t requested) -{ - /* - round upwards - */ - int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS); - int card_count = 1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count; - - /* - one card extra due to alignment - */ - size_t mem_needed = (1 + card_count) * SCM_GC_SIZEOF_CARD - + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG; - scm_t_cell *memory = 0; - - /* - We use calloc to alloc the heap, so it is nicely initialized. - */ - SCM_SYSCALL (memory = (scm_t_cell *) calloc (1, mem_needed)); - - if (memory == NULL) - return 0; - - segment->malloced = memory; - segment->bounds[0] = SCM_GC_CARD_UP (memory); - segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS; - segment->freelist->heap_total_cells += scm_i_segment_cell_count (segment); - - /* - Don't init the mem or the bitvector. This is handled by lazy - sweeping. - */ - segment->next_free_card = segment->bounds[0]; - segment->first_time = 1; - return 1; -} - -int -scm_i_segment_card_count (scm_t_heap_segment *seg) -{ - return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS; -} - -/* - Return the number of available single-cell data cells. - */ -int -scm_i_segment_cell_count (scm_t_heap_segment *seg) -{ - return scm_i_segment_card_count (seg) - * scm_i_segment_cells_per_card (seg); -} - -int -scm_i_segment_cells_per_card (scm_t_heap_segment *seg) -{ - return (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS - + ((seg->span == 2) ? -1 : 0)); -} - -void -scm_i_clear_segment_mark_space (scm_t_heap_segment *seg) -{ - scm_t_cell *markspace = seg->bounds[1]; - - memset (markspace, 0x00, - scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG); -} - - -/* - Force a sweep of this entire segment. - */ -void -scm_i_sweep_segment (scm_t_heap_segment *seg, - scm_t_sweep_statistics *sweep_stats) -{ - int infinity = 1 << 30; - scm_t_cell *remember = seg->next_free_card; - while (scm_i_sweep_some_cards (seg, sweep_stats, infinity) != SCM_EOL) - ; - seg->next_free_card = remember; -} - - -/* Sweep cards from SEG until we've gathered THRESHOLD cells. On - return, SWEEP_STATS, if non-NULL, contains the number of cells that - have been visited and collected. A freelist is returned, - potentially empty. */ -SCM -scm_i_sweep_some_cards (scm_t_heap_segment *seg, - scm_t_sweep_statistics *sweep_stats, - int threshold) -{ - SCM cells = SCM_EOL; - int collected = 0; - int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment *) - = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card; - - scm_t_cell *next_free = seg->next_free_card; - int cards_swept = 0; - while (collected < threshold && next_free < seg->bounds[1]) - { - collected += (*sweeper) (next_free, &cells, seg); - next_free += SCM_GC_CARD_N_CELLS; - cards_swept ++; - } - - if (sweep_stats != NULL) - { - int swept = cards_swept - * ((SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS) - - seg->span + 1); - int collected_cells = collected * seg->span; - sweep_stats->swept += swept; - sweep_stats->collected += collected_cells; - } - - if (next_free == seg->bounds[1]) - { - seg->first_time = 0; - } - - seg->next_free_card = next_free; - return cells; -} - - - -SCM -scm_i_sweep_for_freelist (scm_t_cell_type_statistics *freelist) -{ - scm_t_sweep_statistics stats = { 0 }; - SCM result = scm_i_sweep_some_segments (freelist, &stats); - - scm_i_gc_sweep_stats.collected += stats.collected; - scm_i_gc_sweep_stats.swept += stats.swept; - - freelist->collected += stats.collected; - freelist->swept += stats.swept; - return result; -} - diff --git a/libguile/gc.c b/libguile/gc.c index f3ef585a9..230957bbb 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -21,11 +21,18 @@ # include <config.h> #endif +#include "libguile/gen-scmconfig.h" + #include <stdio.h> #include <errno.h> #include <string.h> #include <assert.h> +#ifdef __ia64__ +#include <ucontext.h> +extern unsigned long * __libc_ia64_register_backing_store_base; +#endif + #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/stime.h" @@ -48,6 +55,8 @@ #include "libguile/gc.h" #include "libguile/dynwind.h" +#include "libguile/boehm-gc.h" + #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif @@ -197,6 +206,12 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, #endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ +/* Hooks. */ +scm_t_c_hook scm_before_gc_c_hook; +scm_t_c_hook scm_before_mark_c_hook; +scm_t_c_hook scm_before_sweep_c_hook; +scm_t_c_hook scm_after_sweep_c_hook; +scm_t_c_hook scm_after_gc_c_hook; /* scm_mtrigger @@ -206,34 +221,17 @@ unsigned long scm_mtrigger; /* GC Statistics Keeping */ -unsigned long scm_cells_allocated = 0; -unsigned long scm_last_cells_allocated = 0; unsigned long scm_mallocated = 0; -long int scm_i_find_heap_calls = 0; -/* Global GC sweep statistics since the last full GC. */ -scm_t_sweep_statistics scm_i_gc_sweep_stats = { 0, 0 }; - -/* Total count of cells marked/swept. */ -static double scm_gc_cells_marked_acc = 0.; -static double scm_gc_cells_marked_conservatively_acc = 0.; -static double scm_gc_cells_swept_acc = 0.; -static double scm_gc_cells_allocated_acc = 0.; - -static unsigned long scm_gc_time_taken = 0; -static unsigned long scm_gc_mark_time_taken = 0; +unsigned long scm_gc_ports_collected = 0; -static unsigned long scm_gc_times = 0; -static int scm_gc_cell_yield_percentage = 0; static unsigned long protected_obj_count = 0; -/* The following are accessed from `gc-malloc.c' and `gc-card.c'. */ -int scm_gc_malloc_yield_percentage = 0; -unsigned long scm_gc_malloc_collected = 0; - SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); -SCM_SYMBOL (sym_heap_size, "cell-heap-size"); +SCM_SYMBOL (sym_heap_size, "heap-size"); +SCM_SYMBOL (sym_heap_free_size, "heap-free-size"); +SCM_SYMBOL (sym_heap_total_allocated, "heap-total-allocated"); SCM_SYMBOL (sym_mallocated, "bytes-malloced"); SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); @@ -287,8 +285,6 @@ SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0, SCM tab = scm_make_hash_table (scm_from_int (57)); SCM alist; - scm_i_all_segments_statistics (tab); - alist = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab); @@ -303,84 +299,27 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, "use of storage.\n") #define FUNC_NAME s_scm_gc_stats { - long i = 0; - SCM heap_segs = SCM_EOL ; - unsigned long int local_scm_mtrigger; - unsigned long int local_scm_mallocated; - unsigned long int local_scm_heap_size; - int local_scm_gc_cell_yield_percentage; - int local_scm_gc_malloc_yield_percentage; - unsigned long int local_scm_cells_allocated; - unsigned long int local_scm_gc_time_taken; - unsigned long int local_scm_gc_times; - unsigned long int local_scm_gc_mark_time_taken; - unsigned long int local_protected_obj_count; - double local_scm_gc_cells_swept; - double local_scm_gc_cells_marked; - double local_scm_gc_cells_marked_conservatively; - double local_scm_total_cells_allocated; SCM answer; - unsigned long *bounds = 0; - int table_size = 0; - SCM_CRITICAL_SECTION_START; + size_t heap_size, free_bytes, bytes_since_gc, total_bytes; + size_t gc_times; - bounds = scm_i_segment_table_info (&table_size); + heap_size = GC_get_heap_size (); + free_bytes = GC_get_free_bytes (); + bytes_since_gc = GC_get_bytes_since_gc (); + total_bytes = GC_get_total_bytes (); + gc_times = GC_gc_no; - /* Below, we cons to produce the resulting list. We want a snapshot of - * the heap situation before consing. - */ - local_scm_mtrigger = scm_mtrigger; - local_scm_mallocated = scm_mallocated; - local_scm_heap_size = - (scm_i_master_freelist.heap_total_cells + scm_i_master_freelist2.heap_total_cells); - - local_scm_cells_allocated = - scm_cells_allocated + scm_i_gc_sweep_stats.collected; - - local_scm_gc_time_taken = scm_gc_time_taken; - local_scm_gc_mark_time_taken = scm_gc_mark_time_taken; - local_scm_gc_times = scm_gc_times; - local_scm_gc_malloc_yield_percentage = scm_gc_malloc_yield_percentage; - local_scm_gc_cell_yield_percentage = scm_gc_cell_yield_percentage; - local_protected_obj_count = protected_obj_count; - local_scm_gc_cells_swept = - (double) scm_gc_cells_swept_acc - + (double) scm_i_gc_sweep_stats.swept; - local_scm_gc_cells_marked = scm_gc_cells_marked_acc - + (double) scm_i_gc_sweep_stats.swept - - (double) scm_i_gc_sweep_stats.collected; - local_scm_gc_cells_marked_conservatively - = scm_gc_cells_marked_conservatively_acc; - - local_scm_total_cells_allocated = scm_gc_cells_allocated_acc - + (double) scm_i_gc_sweep_stats.collected; - - for (i = table_size; i--;) - { - heap_segs = scm_cons (scm_cons (scm_from_ulong (bounds[2*i]), - scm_from_ulong (bounds[2*i+1])), - heap_segs); - } - /* njrev: can any of these scm_cons's or scm_list_n signal a memory error? If so we need a frame here. */ answer = - scm_list_n (scm_cons (sym_gc_time_taken, - scm_from_ulong (local_scm_gc_time_taken)), + scm_list_n (scm_cons (sym_gc_time_taken, SCM_INUM0), +#if 0 scm_cons (sym_cells_allocated, scm_from_ulong (local_scm_cells_allocated)), - scm_cons (sym_total_cells_allocated, - scm_from_double (local_scm_total_cells_allocated)), - scm_cons (sym_heap_size, - scm_from_ulong (local_scm_heap_size)), - scm_cons (sym_cells_marked_conservatively, - scm_from_ulong (local_scm_gc_cells_marked_conservatively)), scm_cons (sym_mallocated, scm_from_ulong (local_scm_mallocated)), scm_cons (sym_mtrigger, scm_from_ulong (local_scm_mtrigger)), - scm_cons (sym_times, - scm_from_ulong (local_scm_gc_times)), scm_cons (sym_gc_mark_time_taken, scm_from_ulong (local_scm_gc_mark_time_taken)), scm_cons (sym_cells_marked, @@ -391,37 +330,22 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, scm_from_long (local_scm_gc_malloc_yield_percentage)), scm_cons (sym_cell_yield, scm_from_long (local_scm_gc_cell_yield_percentage)), - scm_cons (sym_protected_objects, - scm_from_ulong (local_protected_obj_count)), scm_cons (sym_heap_segments, heap_segs), +#endif + scm_cons (sym_heap_size, scm_from_size_t (heap_size)), + scm_cons (sym_heap_free_size, scm_from_size_t (free_bytes)), + scm_cons (sym_heap_total_allocated, + scm_from_size_t (total_bytes)), + scm_cons (sym_protected_objects, + scm_from_ulong (protected_obj_count)), + scm_cons (sym_times, scm_from_size_t (gc_times)), SCM_UNDEFINED); - SCM_CRITICAL_SECTION_END; - - free (bounds); + return answer; } #undef FUNC_NAME -/* - Update nice-to-know-statistics. - */ -static void -gc_end_stats () -{ - /* CELLS SWEPT is another word for the number of cells that were examined - during GC. YIELD is the number that we cleaned out. MARKED is the number - that weren't cleaned. */ - scm_gc_cell_yield_percentage = (scm_i_gc_sweep_stats.collected * 100) / - (scm_i_master_freelist.heap_total_cells + scm_i_master_freelist2.heap_total_cells); - - scm_gc_cells_allocated_acc += - (double) scm_i_gc_sweep_stats.collected; - scm_gc_cells_marked_acc += (double) scm_cells_allocated; - scm_gc_cells_marked_conservatively_acc += (double) scm_i_find_heap_calls; - scm_gc_cells_swept_acc += (double) scm_i_gc_sweep_stats.swept; - - ++scm_gc_times; -} + SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0, (SCM obj), @@ -434,6 +358,29 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0, #undef FUNC_NAME +SCM_DEFINE (scm_gc_disable, "gc-disable", 0, 0, 0, + (), + "Disables the garbage collector. Nested calls are permitted. " + "GC is re-enabled once @code{gc-enable} has been called the " + "same number of times @code{gc-disable} was called.") +#define FUNC_NAME s_scm_gc_disable +{ + GC_disable (); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_gc_enable, "gc-enable", 0, 0, 0, + (), + "Enables the garbage collector.") +#define FUNC_NAME s_scm_gc_enable +{ + GC_enable (); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_gc, "gc", 0, 0, 0, (), "Scans all of SCM objects and reclaims for further use those that are\n" @@ -457,225 +404,10 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, } #undef FUNC_NAME - - - -/* The master is global and common while the freelist will be - * individual for each thread. - */ - -SCM -scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells) -{ - SCM cell; - int did_gc = 0; - - scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex); - scm_gc_running_p = 1; - - *free_cells = scm_i_sweep_for_freelist (freelist); - if (*free_cells == SCM_EOL) - { - float delta = scm_i_gc_heap_size_delta (freelist); - if (delta > 0.0) - { - size_t bytes = ((unsigned long) delta) * sizeof (scm_t_cell); - freelist->heap_segment_idx = - scm_i_get_new_heap_segment (freelist, bytes, abort_on_error); - - *free_cells = scm_i_sweep_for_freelist (freelist); - } - } - - if (*free_cells == SCM_EOL) - { - /* - out of fresh cells. Try to get some new ones. - */ - char reason[] = "0-cells"; - reason[0] += freelist->span; - - did_gc = 1; - scm_i_gc (reason); - - *free_cells = scm_i_sweep_for_freelist (freelist); - } - - if (*free_cells == SCM_EOL) - { - /* - failed getting new cells. Get new juice or die. - */ - float delta = scm_i_gc_heap_size_delta (freelist); - assert (delta > 0.0); - size_t bytes = ((unsigned long) delta) * sizeof (scm_t_cell); - freelist->heap_segment_idx = - scm_i_get_new_heap_segment (freelist, bytes, abort_on_error); - - *free_cells = scm_i_sweep_for_freelist (freelist); - } - - if (*free_cells == SCM_EOL) - abort (); - - cell = *free_cells; - - *free_cells = SCM_FREE_CELL_CDR (cell); - - scm_gc_running_p = 0; - scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex); - - if (did_gc) - scm_c_hook_run (&scm_after_gc_c_hook, 0); - - return cell; -} - - -scm_t_c_hook scm_before_gc_c_hook; -scm_t_c_hook scm_before_mark_c_hook; -scm_t_c_hook scm_before_sweep_c_hook; -scm_t_c_hook scm_after_sweep_c_hook; -scm_t_c_hook scm_after_gc_c_hook; - -static void -scm_check_deprecated_memory_return () -{ - if (scm_mallocated < scm_i_deprecated_memory_return) - { - /* The byte count of allocated objects has underflowed. This is - probably because you forgot to report the sizes of objects you - have allocated, by calling scm_done_malloc or some such. When - the GC freed them, it subtracted their size from - scm_mallocated, which underflowed. */ - fprintf (stderr, - "scm_gc_sweep: Byte count of allocated objects has underflowed.\n" - "This is probably because the GC hasn't been correctly informed\n" - "about object sizes\n"); - abort (); - } - scm_mallocated -= scm_i_deprecated_memory_return; - scm_i_deprecated_memory_return = 0; -} - -/* Must be called while holding scm_i_sweep_mutex. - - This function is fairly long, but it touches various global - variables. To not obscure the side effects on global variables, - this function has not been split up. - */ void scm_i_gc (const char *what) { - unsigned long t_before_gc = 0; - - scm_i_thread_put_to_sleep (); - - scm_c_hook_run (&scm_before_gc_c_hook, 0); - -#ifdef DEBUGINFO - fprintf (stderr,"gc reason %s\n", what); - fprintf (stderr, - scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist)) - ? "*" - : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m")); -#endif - - t_before_gc = scm_c_get_internal_run_time (); - scm_gc_malloc_collected = 0; - - /* - Set freelists to NULL so scm_cons () always triggers gc, causing - the assertion above to fail. - */ - *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; - *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; - - /* - Let's finish the sweep. The conservative GC might point into the - garbage, and marking that would create a mess. - */ - scm_i_sweep_all_segments ("GC", &scm_i_gc_sweep_stats); - scm_check_deprecated_memory_return (); - -#if (SCM_DEBUG_CELL_ACCESSES == 0 && SCM_SIZEOF_UNSIGNED_LONG ==4) - /* Sanity check our numbers. */ - /* TODO(hanwen): figure out why the stats are off on x64_64. */ - /* If this was not true, someone touched mark bits outside of the - mark phase. */ - assert (scm_cells_allocated == scm_i_marked_count ()); - assert (scm_i_gc_sweep_stats.swept - == (scm_i_master_freelist.heap_total_cells - + scm_i_master_freelist2.heap_total_cells)); - assert (scm_i_gc_sweep_stats.collected + scm_cells_allocated - == scm_i_gc_sweep_stats.swept); -#endif /* SCM_DEBUG_CELL_ACCESSES */ - - /* Mark */ - scm_c_hook_run (&scm_before_mark_c_hook, 0); - - scm_mark_all (); - scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc); - - scm_cells_allocated = scm_i_marked_count (); - - /* Sweep - - TODO: the after_sweep hook should probably be moved to just before - the mark, since that's where the sweep is finished in lazy - sweeping. - - MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The - original meaning implied at least two things: that it would be - called when - - 1. the freelist is re-initialized (no evaluation possible, though) - - and - - 2. the heap is "fresh" - (it is well-defined what data is used and what is not) - - Neither of these conditions would hold just before the mark phase. - - Of course, the lazy sweeping has muddled the distinction between - scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if - there were no difference, it would still be useful to have two - distinct classes of hook functions since this can prevent some - bad interference when several modules adds gc hooks. - */ - scm_c_hook_run (&scm_before_sweep_c_hook, 0); - - /* - Nothing here: lazy sweeping. - */ - scm_i_reset_segments (); - - *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL; - *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL; - - /* Invalidate the freelists of other threads. */ - scm_i_thread_invalidate_freelists (); - - scm_c_hook_run (&scm_after_sweep_c_hook, 0); - - gc_end_stats (); - - scm_i_gc_sweep_stats.collected = scm_i_gc_sweep_stats.swept = 0; - scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist); - scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2); - - /* Arguably, this statistic is fairly useless: marking will dominate - the time taken. - */ - scm_gc_time_taken += (scm_c_get_internal_run_time () - t_before_gc); - - scm_i_thread_wake_up (); - /* - For debugging purposes, you could do - scm_i_sweep_all_segments ("debug"), but then the remains of the - cell aren't left to analyse. - */ + GC_gcollect (); } @@ -757,12 +489,7 @@ scm_return_first_int (int i, ...) SCM scm_permanent_object (SCM obj) { - SCM cell = scm_cons (obj, SCM_EOL); - SCM_CRITICAL_SECTION_START; - SCM_SETCDR (cell, scm_permobjs); - scm_permobjs = cell; - SCM_CRITICAL_SECTION_END; - return obj; + return (scm_gc_protect_object (obj)); } @@ -847,48 +574,13 @@ scm_gc_unprotect_object (SCM obj) void scm_gc_register_root (SCM *p) { - SCM handle; - SCM key = scm_from_ulong ((unsigned long) p); - - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: and again. */ - SCM_CRITICAL_SECTION_START; - - handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, - scm_from_int (0)); - /* njrev: note also that the above can probably signal an error */ - SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); - - SCM_CRITICAL_SECTION_END; + /* Nothing. */ } void scm_gc_unregister_root (SCM *p) { - SCM handle; - SCM key = scm_from_ulong ((unsigned long) p); - - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: and again. */ - SCM_CRITICAL_SECTION_START; - - handle = scm_hashv_get_handle (scm_gc_registered_roots, key); - - if (scm_is_false (handle)) - { - fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n"); - abort (); - } - else - { - SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1)); - if (scm_is_eq (count, scm_from_int (0))) - scm_hashv_remove_x (scm_gc_registered_roots, key); - else - SCM_SETCDR (handle, count); - } - - SCM_CRITICAL_SECTION_END; + /* Nothing. */ } void @@ -934,6 +626,29 @@ scm_getenv_int (const char *var, int def) void scm_storage_prehistory () { + GC_all_interior_pointers = 0; + + GC_INIT (); + +#ifdef SCM_I_GSC_USE_PTHREAD_THREADS + /* When using GC 6.8, this call is required to initialize thread-local + freelists (shouldn't be necessary with GC 7.0). */ + GC_init (); +#endif + + GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2); + + /* We only need to register a displacement for those types for which the + higher bits of the type tag are used to store a pointer (that is, a + pointer to an 8-octet aligned region). For `scm_tc3_struct', this is + handled in `scm_alloc_struct ()'. */ + GC_REGISTER_DISPLACEMENT (scm_tc3_cons); + GC_REGISTER_DISPLACEMENT (scm_tc3_closure); + + /* Sanity check. */ + if (!GC_is_visible (scm_sys_protects)) + abort (); + scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL); scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL); scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL); @@ -952,8 +667,7 @@ scm_init_storage () while (j) scm_sys_protects[--j] = SCM_BOOL_F; - scm_gc_init_freelist (); - scm_gc_init_malloc (); + j = SCM_HEAP_SEG_SIZE; #if 0 /* We can't have a cleanup handler since we have no thread to run it @@ -970,9 +684,7 @@ scm_init_storage () #endif scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257)); - scm_permobjs = SCM_EOL; scm_protects = scm_c_make_hash_table (31); - scm_gc_registered_roots = scm_c_make_hash_table (31); return 0; } @@ -1040,10 +752,90 @@ mark_gc_async (void * hook_data SCM_UNUSED, return NULL; } +char const * +scm_i_tag_name (scm_t_bits tag) +{ + if (tag >= 255) + { + if (tag == scm_tc_free_cell) + return "free cell"; + + { + int k = 0xff & (tag >> 8); + return (scm_smobs[k].name); + } + } + + switch (tag) /* 7 bits */ + { + case scm_tcs_struct: + return "struct"; + case scm_tcs_cons_imcar: + return "cons (immediate car)"; + case scm_tcs_cons_nimcar: + return "cons (non-immediate car)"; + case scm_tcs_closures: + return "closures"; + case scm_tc7_pws: + return "pws"; + case scm_tc7_wvect: + return "weak vector"; + case scm_tc7_vector: + return "vector"; +#ifdef CCLO + case scm_tc7_cclo: + return "compiled closure"; +#endif + case scm_tc7_number: + switch (tag) + { + case scm_tc16_real: + return "real"; + break; + case scm_tc16_big: + return "bignum"; + break; + case scm_tc16_complex: + return "complex number"; + break; + case scm_tc16_fraction: + return "fraction"; + break; + } + break; + case scm_tc7_string: + return "string"; + break; + case scm_tc7_stringbuf: + return "string buffer"; + break; + case scm_tc7_symbol: + return "symbol"; + break; + case scm_tc7_variable: + return "variable"; + break; + case scm_tcs_subrs: + return "subrs"; + break; + case scm_tc7_port: + return "port"; + break; + case scm_tc7_smob: + return "smob"; /* should not occur. */ + break; + } + + return NULL; +} + + + + void scm_init_gc () { - scm_gc_init_mark (); + /* `GC_INIT ()' was invoked in `scm_storage_prehistory ()'. */ scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0)); scm_c_define ("after-gc-hook", scm_after_gc_hook); @@ -1056,49 +848,13 @@ scm_init_gc () #include "libguile/gc.x" } -#ifdef __ia64__ -# ifdef __hpux -# include <sys/param.h> -# include <sys/pstat.h> -void * -scm_ia64_register_backing_store_base (void) -{ - struct pst_vm_status vm_status; - int i = 0; - while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1) - if (vm_status.pst_type == PS_RSESTACK) - return (void *) vm_status.pst_vaddr; - abort (); -} -void * -scm_ia64_ar_bsp (const void *ctx) -{ - uint64_t bsp; - __uc_get_ar_bsp (ctx, &bsp); - return (void *) bsp; -} -# endif /* hpux */ -# ifdef linux -# include <ucontext.h> -void * -scm_ia64_register_backing_store_base (void) -{ - extern void *__libc_ia64_register_backing_store_base; - return __libc_ia64_register_backing_store_base; -} -void * -scm_ia64_ar_bsp (const void *opaque) -{ - const ucontext_t *ctx = opaque; - return (void *) ctx->uc_mcontext.sc_ar_bsp; -} -# endif /* linux */ -#endif /* __ia64__ */ void scm_gc_sweep (void) #define FUNC_NAME "scm_gc_sweep" { + /* FIXME */ + fprintf (stderr, "%s: doing nothing\n", __FUNCTION__); } #undef FUNC_NAME diff --git a/libguile/gc.h b/libguile/gc.h index fbd971036..db55abc18 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -3,7 +3,7 @@ #ifndef SCM_GC_H #define SCM_GC_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -28,54 +28,12 @@ #include "libguile/threads.h" - -/* Cell allocation and garbage collection work rouhgly in the - following manner: - - Each thread has a 'freelist', which is a list of available cells. - (It actually has two freelists, one for single cells and one for - double cells. Everything works analogous for double cells.) - - When a thread wants to allocate a cell and the freelist is empty, - it refers to a global list of unswept 'cards'. A card is a small - block of cells that are contigous in memory, together with the - corresponding mark bits. A unswept card is one where the mark bits - are set for cells that have been in use during the last global mark - phase, but the unmarked cells of the card have not been scanned and - freed yet. - - The thread takes one of the unswept cards and sweeps it, thereby - building a new freelist that it then uses. Sweeping a card will - call the smob free functions of unmarked cells, for example, and - thus, these free functions can run at any time, in any thread. - - When there are no more unswept cards available, the thread performs - a global garbage collection. For this, all other threads are - stopped. A global mark is performed and all cards are put into the - global list of unswept cards. Whennecessary, new cards are - allocated and initialized at this time. The other threads are then - started again. -*/ - typedef struct scm_t_cell { SCM word_0; SCM word_1; } scm_t_cell; -/* - CARDS - - A card is a small `page' of memory; it will be the unit for lazy - sweeping, generations, etc. The first cell of a card contains a - pointer to the mark bitvector, so that we can find the bitvector - efficiently: we knock off some lowerorder bits. - - The size on a 32 bit machine is 256 cells = 2kb. The card [XXX] -*/ - - - /* Cray machines have pointers that are incremented once for each * word, rather than each byte, the 3 most significant bits encode the * byte within the word. The following macros deal with this by @@ -92,80 +50,6 @@ typedef struct scm_t_cell #endif /* def _UNICOS */ -#define SCM_GC_CARD_N_HEADER_CELLS 1 -#define SCM_GC_CARD_N_CELLS 256 -#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell) - -#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0)) -#define SCM_GC_SET_CARD_BVEC(card, bvec) \ - ((card)->word_0 = (SCM) (bvec)) -#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1)) -#define SCM_GC_SET_CARD_FLAGS(card, flags) \ - ((card)->word_1 = (SCM) (flags)) - -#define SCM_GC_GET_CARD_FLAG(card, shift) \ - (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift))) -#define SCM_GC_SET_CARD_FLAG(card, shift) \ - (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift)))) -#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \ - (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift)))) - -/* - Remove card flags. They hamper lazy initialization, and aren't used - anyways. - */ - -/* card addressing. for efficiency, cards are *always* aligned to - SCM_GC_CARD_SIZE. */ - -#define SCM_GC_CARD_SIZE_MASK (SCM_GC_SIZEOF_CARD-1) -#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK) - -#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK)) -#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT) -#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x)) -#define SCM_GC_SET_CELL_BVEC(x, bvec) SCM_GC_SET_CARD_BVEC (SCM_GC_CELL_CARD (x), bvec) -#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) -#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) -#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x)) - -#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1) -#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD - -/* low level bit banging aids */ -typedef unsigned long scm_t_c_bvec_long; - -#if (SCM_SIZEOF_UNSIGNED_LONG == 8) -# define SCM_C_BVEC_LONG_BITS 64 -# define SCM_C_BVEC_OFFSET_SHIFT 6 -# define SCM_C_BVEC_POS_MASK 63 -# define SCM_CELL_SIZE_SHIFT 4 -#else -# define SCM_C_BVEC_LONG_BITS 32 -# define SCM_C_BVEC_OFFSET_SHIFT 5 -# define SCM_C_BVEC_POS_MASK 31 -# define SCM_CELL_SIZE_SHIFT 3 -#endif - -#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT) - -#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK))) -#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK))) -#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK))) - -/* testing and changing GC marks */ -#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x) - -SCM_INTERNAL void scm_i_ensure_marking(void); - -#if (SCM_DEBUG_MARKING_API == 1) -#define SCM_I_ENSURE_MARKING scm_i_ensure_marking(), -#else -#define SCM_I_ENSURE_MARKING -#endif - -#define SCM_SET_GC_MARK(x) SCM_I_ENSURE_MARKING SCM_GC_CELL_SET_BIT (x) -#define SCM_CLEAR_GC_MARK(x) SCM_I_ENSURE_MARKING SCM_GC_CELL_CLEAR_BIT (x) /* Low level cell data accessing macros. These macros should only be used * from within code related to garbage collection issues, since they will @@ -286,10 +170,8 @@ SCM_API scm_i_pthread_key_t scm_i_freelist2; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist; SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2; -SCM_API unsigned long scm_gc_malloc_collected; -SCM_API unsigned long scm_cells_allocated; -SCM_API int scm_gc_malloc_yield_percentage; SCM_API unsigned long scm_mallocated; +SCM_API unsigned long scm_gc_ports_collected; SCM_API unsigned long scm_mtrigger; SCM_API SCM scm_after_gc_hook; @@ -322,15 +204,13 @@ SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag); SCM_API SCM scm_object_address (SCM obj); +SCM_API SCM scm_gc_enable (void); +SCM_API SCM scm_gc_disable (void); SCM_API SCM scm_gc_stats (void); SCM_API SCM scm_gc_live_object_stats (void); SCM_API SCM scm_gc (void); -SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist); -SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist); -SCM_INTERNAL void scm_i_gc (const char *what); +SCM_API void scm_i_gc (const char *what); SCM_API void scm_gc_mark (SCM p); -SCM_API void scm_gc_mark_dependencies (SCM p); -SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n); SCM_API int scm_in_heap_p (SCM value); SCM_API void scm_gc_sweep (void); @@ -343,6 +223,7 @@ SCM_API void scm_gc_register_collectable_memory (void *mem, size_t size, const char *what); SCM_API void scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what); +SCM_API void *scm_gc_malloc_pointerless (size_t size, const char *what); SCM_API void *scm_gc_calloc (size_t size, const char *what); SCM_API void *scm_gc_malloc (size_t size, const char *what); SCM_API void *scm_gc_realloc (void *mem, size_t old_size, @@ -390,8 +271,7 @@ SCM_API void scm_gc_register_roots (SCM *b, unsigned long n); SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n); SCM_API void scm_storage_prehistory (void); SCM_API int scm_init_storage (void); -SCM_API void *scm_get_stack_base (void); -SCM_INTERNAL void scm_init_gc (void); +SCM_API void scm_init_gc (void); #if SCM_ENABLE_DEPRECATED == 1 diff --git a/libguile/gc_os_dep.c b/libguile/gc_os_dep.c deleted file mode 100644 index 4223803c3..000000000 --- a/libguile/gc_os_dep.c +++ /dev/null @@ -1,1943 +0,0 @@ -/* - * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers - * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved. - * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved. - * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved. - * Copyright (c) 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation - * - * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED - * OR IMPLIED. ANY USE IS AT YOUR OWN RISK. - * - * Permission is hereby granted to use or copy this program - * for any purpose, provided the above notices are retained on all copies. - * Permission to modify the code and to distribute modified code is granted, - * provided the above notices are retained, and a notice that the code was - * modified is included with the above copyright notice. - * - */ - -/* - * Copied from gc5.2, files "os_dep.c", "gc_priv.h", "mark.c" and "gcconfig.h", - * and modified for Guile by Marius Vollmer. - */ - -#if HAVE_CONFIG_H -# include <config.h> -#endif - -#include <ctype.h> -#include "libguile/gc.h" -#include "libguile/scmconfig.h" - -#ifdef HAVE_LIBC_STACK_END - -extern void *__libc_stack_end; - -void * -scm_get_stack_base () -{ - return __libc_stack_end; -} - -#else - -#define ABORT(msg) abort () - -typedef char * ptr_t; /* A generic pointer to which we can add */ - /* byte displacements. */ - /* Preferably identical to caddr_t, if it */ - /* exists. */ - -/* Define word and signed_word to be unsigned and signed types of the */ -/* size as char * or void *. There seems to be no way to do this */ -/* even semi-portably. The following is probably no better/worse */ -/* than almost anything else. */ -/* The ANSI standard suggests that size_t and ptr_diff_t might be */ -/* better choices. But those appear to have incorrect definitions */ -/* on may systems. Notably "typedef int size_t" seems to be both */ -/* frequent and WRONG. */ -typedef unsigned long GC_word; -typedef long GC_signed_word; - -typedef GC_word word; -typedef GC_signed_word signed_word; - -typedef int GC_bool; -# define TRUE 1 -# define FALSE 0 - -#if defined(__STDC__) -# include <stdlib.h> -# if !(defined( sony_news ) ) -# include <stddef.h> -# endif -# define VOLATILE volatile -#else -# ifdef MSWIN32 -# include <stdlib.h> -# endif -# define VOLATILE -#endif - -/* Machine dependent parameters. Some tuning parameters can be found */ -/* near the top of gc_private.h. */ - -/* Machine specific parts contributed by various people. See README file. */ - -/* First a unified test for Linux: */ -# if defined(linux) || defined(__linux__) -# define LINUX -# endif - -/* Determine the machine type: */ -# if defined(sun) && defined(mc68000) -# define M68K -# define SUNOS4 -# define mach_type_known -# endif -# if defined(hp9000s300) -# define M68K -# define HP -# define mach_type_known -# endif -# if defined(__OpenBSD__) && defined(m68k) -# define M68K -# define OPENBSD -# define mach_type_known -# endif -# if defined(__OpenBSD__) && defined(__sparc__) -# define SPARC -# define OPENBSD -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__alpha__) -# define ALPHA -# define NETBSD -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__powerpc__) -# define POWERPC -# define NETBSD -# define mach_type_known -# endif -/* in netbsd 2.0 only __m68k__ is defined, not m68k */ -# if defined(__NetBSD__) && (defined(m68k) || defined(__m68k__)) -# define M68K -# define NETBSD -# define mach_type_known -# endif -/* in netbsd 2.0 only __arm__ is defined, not arm32 */ -# if defined(__NetBSD__) && (defined(arm32) || defined(__arm__)) -# define ARM32 -# define NETBSD -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(__sparc__) -# define SPARC -# define NETBSD -# define mach_type_known -# endif -# if defined(vax) -# define VAX -# ifdef ultrix -# define ULTRIX -# else -# define BSD -# endif -# define mach_type_known -# endif -# if defined(mips) || defined(__mips) -# define MIPS -# if !defined(LINUX) -# if defined(ultrix) || defined(__ultrix) || defined(__NetBSD__) -# define ULTRIX -# else -# if defined(_SYSTYPE_SVR4) || defined(SYSTYPE_SVR4) \ - || defined(__SYSTYPE_SVR4__) -# define IRIX5 /* or IRIX 6.X */ -# else -# define RISCOS /* or IRIX 4.X */ -# endif -# endif -# endif /* !LINUX */ -# define mach_type_known -# endif -# if defined(sequent) && defined(i386) -# define I386 -# define SEQUENT -# define mach_type_known -# endif -# if defined(sun) && defined(i386) -# define I386 -# define SUNOS5 -# define mach_type_known -# endif -# if (defined(__OS2__) || defined(__EMX__)) && defined(__32BIT__) -# define I386 -# define OS2 -# define mach_type_known -# endif -# if defined(ibm032) -# define RT -# define mach_type_known -# endif -# if defined(sun) && (defined(sparc) || defined(__sparc)) -# define SPARC - /* Test for SunOS 5.x */ -# include <errno.h> -# ifdef ECHRNG -# define SUNOS5 -# else -# define SUNOS4 -# endif -# define mach_type_known -# endif -# if defined(sparc) && defined(unix) && !defined(sun) && !defined(linux) \ - && !defined(__OpenBSD__) -# define SPARC -# define DRSNX -# define mach_type_known -# endif -# if defined(_IBMR2) -# define RS6000 -# define mach_type_known -# endif -# if defined(_M_XENIX) && defined(_M_SYSV) && defined(_M_I386) - /* The above test may need refinement */ -# define I386 -# if defined(_SCO_ELF) -# define SCO_ELF -# else -# define SCO -# endif -# define mach_type_known -# endif -# if defined(_AUX_SOURCE) -# define M68K -# define SYSV -# define mach_type_known -# endif -# if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \ - || defined(hppa) || defined(__hppa__) -# define HP_PA -# ifndef LINUX -# define HPUX -# endif -# define mach_type_known -# endif -# if defined(LINUX) && (defined(i386) || defined(__i386__)) -# define I386 -# define mach_type_known -# endif -# if defined(LINUX) && (defined(__ia64__) || defined(__ia64)) -# define IA64 -# define mach_type_known -# endif -# if defined(LINUX) && defined(powerpc) -# define POWERPC -# define mach_type_known -# endif -# if defined(LINUX) && defined(__mc68000__) -# define M68K -# define mach_type_known -# endif -# if defined(LINUX) && (defined(sparc) || defined(__sparc__)) -# define SPARC -# define mach_type_known -# endif -# if defined(LINUX) && (defined(arm) || defined (__arm__)) -# define ARM32 -# define mach_type_known -# endif -# if defined(__alpha) || defined(__alpha__) -# define ALPHA -# if !defined(LINUX) && !defined (NETBSD) -# define OSF1 /* a.k.a Digital Unix */ -# endif -# define mach_type_known -# endif -# if defined(_AMIGA) && !defined(AMIGA) -# define AMIGA -# endif -# ifdef AMIGA -# define M68K -# define mach_type_known -# endif -# if defined(THINK_C) || defined(__MWERKS__) && !defined(__powerc) -# define M68K -# define MACOS -# define mach_type_known -# endif -# if defined(__MWERKS__) && defined(__powerc) -# define POWERPC -# define MACOS -# define mach_type_known -# endif -# if defined(macosx) || \ - (defined(__APPLE__) && defined(__MACH__) && defined(__ppc__)) -# define MACOSX -# define POWERPC -# define mach_type_known -# endif -# if defined(NeXT) && defined(mc68000) -# define M68K -# define NEXT -# define mach_type_known -# endif -# if defined(NeXT) && defined(i386) -# define I386 -# define NEXT -# define mach_type_known -# endif -# if defined(__OpenBSD__) && (defined(i386) || defined(__i386__)) -# define I386 -# define OPENBSD -# define mach_type_known -# endif -# if defined(__FreeBSD__) && defined(i386) -# define I386 -# define FREEBSD -# define mach_type_known -# endif -# if defined(__NetBSD__) && defined(i386) -# define I386 -# define NETBSD -# define mach_type_known -# endif -# if defined(bsdi) && defined(i386) -# define I386 -# define BSDI -# define mach_type_known -# endif -# if !defined(mach_type_known) && defined(__386BSD__) -# define I386 -# define THREE86BSD -# define mach_type_known -# endif -# if defined(_CX_UX) && defined(_M88K) -# define M88K -# define CX_UX -# define mach_type_known -# endif -# if defined(DGUX) -# define M88K - /* DGUX defined */ -# define mach_type_known -# endif -# if (defined(_MSDOS) || defined(_MSC_VER)) && (_M_IX86 >= 300) \ - || defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__) -# define I386 -# define MSWIN32 /* or Win32s */ -# define mach_type_known -# endif -# if defined(__DJGPP__) -# define I386 -# ifndef DJGPP -# define DJGPP /* MSDOS running the DJGPP port of GCC */ -# endif -# define mach_type_known -# endif -# if defined(__CYGWIN32__) || defined(__CYGWIN__) -# define I386 -# define CYGWIN32 -# define mach_type_known -# endif -# if defined(__MINGW32__) -# define I386 -# define MSWIN32 -# define mach_type_known -# endif -# if defined(__BORLANDC__) -# define I386 -# define MSWIN32 -# define mach_type_known -# endif -# if defined(_UTS) && !defined(mach_type_known) -# define S370 -# define UTS4 -# define mach_type_known -# endif -# if defined(__pj__) -# define PJ -# define mach_type_known -# endif -/* Ivan Demakov */ -# if defined(__WATCOMC__) && defined(__386__) -# define I386 -# if !defined(OS2) && !defined(MSWIN32) && !defined(DOS4GW) -# if defined(__OS2__) -# define OS2 -# else -# if defined(__WINDOWS_386__) || defined(__NT__) -# define MSWIN32 -# else -# define DOS4GW -# endif -# endif -# endif -# define mach_type_known -# endif -# if defined(__s390__) && defined(LINUX) -# define S370 -# define mach_type_known -# endif -# if defined(__GNU__) -# define I386 -# define GNU -# define mach_type_known -# endif -# if defined(__SCO_VERSION__) -# define I386 -# define SYSV -# define mach_type_known -# endif - -/* Feel free to add more clauses here */ - -/* Or manually define the machine type here. A machine type is */ -/* characterized by the architecture. Some */ -/* machine types are further subdivided by OS. */ -/* the macros ULTRIX, RISCOS, and BSD to distinguish. */ -/* Note that SGI IRIX is treated identically to RISCOS. */ -/* SYSV on an M68K actually means A/UX. */ -/* The distinction in these cases is usually the stack starting address */ -# ifndef mach_type_known - -void * -scm_get_stack_base () -{ - ABORT ("Can't determine stack base"); - return NULL; -} - -# else - /* Mapping is: M68K ==> Motorola 680X0 */ - /* (SUNOS4,HP,NEXT, and SYSV (A/UX), */ - /* MACOS and AMIGA variants) */ - /* I386 ==> Intel 386 */ - /* (SEQUENT, OS2, SCO, LINUX, NETBSD, */ - /* FREEBSD, THREE86BSD, MSWIN32, */ - /* BSDI,SUNOS5, NEXT, other variants) */ - /* NS32K ==> Encore Multimax */ - /* MIPS ==> R2000 or R3000 */ - /* (RISCOS, ULTRIX variants) */ - /* VAX ==> DEC VAX */ - /* (BSD, ULTRIX variants) */ - /* RS6000 ==> IBM RS/6000 AIX3.X */ - /* RT ==> IBM PC/RT */ - /* HP_PA ==> HP9000/700 & /800 */ - /* HP/UX */ - /* SPARC ==> SPARC under SunOS */ - /* (SUNOS4, SUNOS5, */ - /* DRSNX variants) */ - /* ALPHA ==> DEC Alpha */ - /* (OSF1 and LINUX variants) */ - /* M88K ==> Motorola 88XX0 */ - /* (CX_UX and DGUX) */ - /* S370 ==> 370-like machine */ - /* running Amdahl UTS4 */ - /* ARM32 ==> Intel StrongARM */ - /* IA64 ==> Intel IA64 */ - /* (e.g. Itanium) */ - - -/* - * For each architecture and OS, the following need to be defined: - * - * CPP_WORD_SZ is a simple integer constant representing the word size. - * in bits. We assume byte addressibility, where a byte has 8 bits. - * We also assume CPP_WORD_SZ is either 32 or 64. - * (We care about the length of pointers, not hardware - * bus widths. Thus a 64 bit processor with a C compiler that uses - * 32 bit pointers should use CPP_WORD_SZ of 32, not 64. Default is 32.) - * - * MACH_TYPE is a string representation of the machine type. - * OS_TYPE is analogous for the OS. - * - * ALIGNMENT is the largest N, such that - * all pointer are guaranteed to be aligned on N byte boundaries. - * defining it to be 1 will always work, but perform poorly. - * - * DATASTART is the beginning of the data segment. - * On UNIX systems, the collector will scan the area between DATASTART - * and DATAEND for root pointers. - * - * DATAEND, if not &end. - * - * ALIGN_DOUBLE of GC_malloc should return blocks aligned to twice - * the pointer size. - * - * STACKBOTTOM is the cool end of the stack, which is usually the - * highest address in the stack. - * Under PCR or OS/2, we have other ways of finding thread stacks. - * For each machine, the following should: - * 1) define SCM_STACK_GROWS_UP if the stack grows toward higher addresses, and - * 2) define exactly one of - * STACKBOTTOM (should be defined to be an expression) - * HEURISTIC1 - * HEURISTIC2 - * If either of the last two macros are defined, then STACKBOTTOM is computed - * during collector startup using one of the following two heuristics: - * HEURISTIC1: Take an address inside GC_init's frame, and round it up to - * the next multiple of STACK_GRAN. - * HEURISTIC2: Take an address inside GC_init's frame, increment it repeatedly - * in small steps (decrement if SCM_STACK_GROWS_UP), and read the value - * at each location. Remember the value when the first - * Segmentation violation or Bus error is signalled. Round that - * to the nearest plausible page boundary, and use that instead - * of STACKBOTTOM. - * - * Gustavo Rodriguez-Rivera points out that on most (all?) Unix machines, - * the value of environ is a pointer that can serve as STACKBOTTOM. - * I expect that HEURISTIC2 can be replaced by this approach, which - * interferes far less with debugging. - * - * If no expression for STACKBOTTOM can be found, and neither of the above - * heuristics are usable, the collector can still be used with all of the above - * undefined, provided one of the following is done: - * 1) GC_mark_roots can be changed to somehow mark from the correct stack(s) - * without reference to STACKBOTTOM. This is appropriate for use in - * conjunction with thread packages, since there will be multiple stacks. - * (Allocating thread stacks in the heap, and treating them as ordinary - * heap data objects is also possible as a last resort. However, this is - * likely to introduce significant amounts of excess storage retention - * unless the dead parts of the thread stacks are periodically cleared.) - * 2) Client code may set GC_stackbottom before calling any GC_ routines. - * If the author of the client code controls the main program, this is - * easily accomplished by introducing a new main program, setting - * GC_stackbottom to the address of a local variable, and then calling - * the original main program. The new main program would read something - * like: - * - * # include "gc_private.h" - * - * main(argc, argv, envp) - * int argc; - * char **argv, **envp; - * { - * int dummy; - * - * GC_stackbottom = (ptr_t)(&dummy); - * return(real_main(argc, argv, envp)); - * } - * - * - * Each architecture may also define the style of virtual dirty bit - * implementation to be used: - * MPROTECT_VDB: Write protect the heap and catch faults. - * PROC_VDB: Use the SVR4 /proc primitives to read dirty bits. - * - * An architecture may define DYNAMIC_LOADING if dynamic_load.c - * defined GC_register_dynamic_libraries() for the architecture. - * - * An architecture may define PREFETCH(x) to preload the cache with *x. - * This defaults to a no-op. - * - * PREFETCH_FOR_WRITE(x) is used if *x is about to be written. - * - * An architecture may also define CLEAR_DOUBLE(x) to be a fast way to - * clear the two words at GC_malloc-aligned address x. By default, - * word stores of 0 are used instead. - */ - - -# define STACK_GRAN 0x1000000 -# ifdef M68K -# define MACH_TYPE "M68K" -# define ALIGNMENT 2 -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define HEURISTIC2 - extern char etext; -# define DATASTART ((ptr_t)(&etext)) -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 - extern char etext; -# define DATASTART ((ptr_t)(&etext)) -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define STACKBOTTOM ((ptr_t)0xf0000000) -# define MPROTECT_VDB -# ifdef __ELF__ -# define DYNAMIC_LOADING - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ - extern int _end; -# define DATAEND (&_end) -# else - extern int etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) -# endif -# endif -# ifdef SUNOS4 -# define OS_TYPE "SUNOS4" - extern char etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ffff) & ~0x1ffff)) -# define HEURISTIC1 /* differs */ -# define DYNAMIC_LOADING -# endif -# ifdef HP -# define OS_TYPE "HP" - extern char etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) -# define STACKBOTTOM ((ptr_t) 0xffeffffc) - /* empirically determined. seems to work. */ -# include <unistd.h> -# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) -# endif -# ifdef SYSV -# define OS_TYPE "SYSV" - extern etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \ - & ~0x3fffff) \ - +((word)&etext & 0x1fff)) - /* This only works for shared-text binaries with magic number 0413. - The other sorts of SysV binaries put the data at the end of the text, - in which case the default of &etext would work. Unfortunately, - handling both would require having the magic-number available. - -- Parag - */ -# define STACKBOTTOM ((ptr_t)0xFFFFFFFE) - /* The stack starts at the top of memory, but */ - /* 0x0 cannot be used as setjump_test complains */ - /* that the stack direction is incorrect. Two */ - /* bytes down from 0x0 should be safe enough. */ - /* --Parag */ -# include <sys/mmu.h> -# define GETPAGESIZE() PAGESIZE /* Is this still right? */ -# endif -# ifdef AMIGA -# define OS_TYPE "AMIGA" - /* STACKBOTTOM and DATASTART handled specially */ - /* in os_dep.c */ -# define DATAEND /* not needed */ -# define GETPAGESIZE() 4096 -# endif -# ifdef MACOS -# ifndef __LOWMEM__ -# include <LowMem.h> -# endif -# define OS_TYPE "MACOS" - /* see os_dep.c for details of global data segments. */ -# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) -# define DATAEND /* not needed */ -# define GETPAGESIZE() 4096 -# endif -# ifdef NEXT -# define OS_TYPE "NEXT" -# define DATASTART ((ptr_t) get_etext()) -# define STACKBOTTOM ((ptr_t) 0x4000000) -# define DATAEND /* not needed */ -# endif -# endif - -# ifdef POWERPC -# define MACH_TYPE "POWERPC" -# ifdef MACOS -# define ALIGNMENT 2 /* Still necessary? Could it be 4? */ -# ifndef __LOWMEM__ -# include <LowMem.h> -# endif -# define OS_TYPE "MACOS" - /* see os_dep.c for details of global data segments. */ -# define STACKBOTTOM ((ptr_t) LMGetCurStackBase()) -# define DATAEND /* not needed */ -# endif -# ifdef LINUX -# define ALIGNMENT 4 /* Guess. Can someone verify? */ - /* This was 2, but that didn't sound right. */ -# define OS_TYPE "LINUX" -# define HEURISTIC1 -# define DYNAMIC_LOADING -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 - /* Stack usually starts at 0x80000000 */ -# define LINUX_DATA_START - extern int _end; -# define DATAEND (&_end) -# endif -# ifdef MACOSX -# define ALIGNMENT 4 -# define OS_TYPE "MACOSX" -# define DATASTART ((ptr_t) get_etext()) -# define STACKBOTTOM ((ptr_t) 0xc0000000) -# define DATAEND /* not needed */ -# endif -# endif - -# ifdef VAX -# define MACH_TYPE "VAX" -# define ALIGNMENT 4 /* Pointers are longword aligned by 4.2 C compiler */ - extern char etext; -# define DATASTART ((ptr_t)(&etext)) -# ifdef BSD -# define OS_TYPE "BSD" -# define HEURISTIC1 - /* HEURISTIC2 may be OK, but it's hard to test. */ -# endif -# ifdef ULTRIX -# define OS_TYPE "ULTRIX" -# define STACKBOTTOM ((ptr_t) 0x7fffc800) -# endif -# endif - -# ifdef RT -# define MACH_TYPE "RT" -# define ALIGNMENT 4 -# define DATASTART ((ptr_t) 0x10000000) -# define STACKBOTTOM ((ptr_t) 0x1fffd800) -# endif - -# ifdef SPARC -# define MACH_TYPE "SPARC" -# define ALIGNMENT 4 /* Required by hardware */ -# define ALIGN_DOUBLE - extern int etext; -# ifdef SUNOS5 -# define OS_TYPE "SUNOS5" - extern int _etext; - extern int _end; - extern char * GC_SysVGetDataStart(); -# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext) -# define DATAEND (&_end) -# ifndef USE_MMAP -# define USE_MMAP -# endif -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# define PROC_VDB -/* HEURISTIC1 reportedly no longer works under 2.7. Thus we */ -/* switched to HEURISTIC2, eventhough it creates some debugging */ -/* issues. */ -# define HEURISTIC2 -# include <unistd.h> -# define GETPAGESIZE() sysconf(_SC_PAGESIZE) - /* getpagesize() appeared to be missing from at least one */ - /* Solaris 5.4 installation. Weird. */ -# define DYNAMIC_LOADING -# endif -# ifdef SUNOS4 -# define OS_TYPE "SUNOS4" - /* [If you have a weak stomach, don't read this.] */ - /* We would like to use: */ -/* # define DATASTART ((ptr_t)((((word) (&etext)) + 0x1fff) & ~0x1fff)) */ - /* This fails occasionally, due to an ancient, but very */ - /* persistent ld bug. &etext is set 32 bytes too high. */ - /* We instead read the text segment size from the a.out */ - /* header, which happens to be mapped into our address space */ - /* at the start of the text segment. The detective work here */ - /* was done by Robert Ehrlich, Manuel Serrano, and Bernard */ - /* Serpette of INRIA. */ - /* This assumes ZMAGIC, i.e. demand-loadable executables. */ -# define TEXTSTART 0x2000 -# define DATASTART ((ptr_t)(*(int *)(TEXTSTART+0x4)+TEXTSTART)) -# define MPROTECT_VDB -# define HEURISTIC1 -# define DYNAMIC_LOADING -# endif -# ifdef DRSNX -# define CPP_WORDSZ 32 -# define OS_TYPE "DRSNX" - extern char * GC_SysVGetDataStart(); - extern int etext; -# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext) -# define MPROTECT_VDB -# define STACKBOTTOM ((ptr_t) 0xdfff0000) -# define DYNAMIC_LOADING -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# ifdef __ELF__ -# define LINUX_DATA_START -# define DYNAMIC_LOADING -# else - Linux Sparc non elf ? -# endif - extern int _end; -# define DATAEND (&_end) -# define SVR4 -# define STACKBOTTOM ((ptr_t) 0xf0000000) -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# define STACKBOTTOM ((ptr_t) 0xf8000000) -# define DATASTART ((ptr_t)(&etext)) -# endif -# endif - -# ifdef I386 -# define MACH_TYPE "I386" -# define ALIGNMENT 4 /* Appears to hold for all "32 bit" compilers */ - /* except Borland. The -a4 option fixes */ - /* Borland. */ - /* Ivan Demakov: For Watcom the option is -zp4. */ -# ifndef SMALL_CONFIG -# define ALIGN_DOUBLE /* Not strictly necessary, but may give speed */ - /* improvement on Pentiums. */ -# endif -# ifdef SEQUENT -# define OS_TYPE "SEQUENT" - extern int etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) -# define STACKBOTTOM ((ptr_t) 0x3ffff000) -# endif -# ifdef SUNOS5 -# define OS_TYPE "SUNOS5" - extern int etext, _start; - extern char * GC_SysVGetDataStart(); -# define DATASTART GC_SysVGetDataStart(0x1000, &etext) -# define STACKBOTTOM ((ptr_t)(&_start)) -/** At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */ -/*# define PROC_VDB*/ -# define DYNAMIC_LOADING -# ifndef USE_MMAP -# define USE_MMAP -# endif -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x40000000 -# else -# define HEAP_START DATAEND -# endif -# endif -# ifdef SCO -# define OS_TYPE "SCO" - extern int etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \ - & ~0x3fffff) \ - +((word)&etext & 0xfff)) -# define STACKBOTTOM ((ptr_t) 0x7ffffffc) -# endif -# ifdef SCO_ELF -# define OS_TYPE "SCO_ELF" - extern int etext; -# define DATASTART ((ptr_t)(&etext)) -# define STACKBOTTOM ((ptr_t) 0x08048000) -# define DYNAMIC_LOADING -# define ELF_CLASS ELFCLASS32 -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define LINUX_STACKBOTTOM -# if 0 -# define HEURISTIC1 -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 - /* STACKBOTTOM is usually 0xc0000000, but this changes with */ - /* different kernel configurations. In particular, systems */ - /* with 2GB physical memory will usually move the user */ - /* address space limit, and hence initial SP to 0x80000000. */ -# endif -# if !defined(LINUX_THREADS) || !defined(REDIRECT_MALLOC) -# define MPROTECT_VDB -# else - /* We seem to get random errors in incremental mode, */ - /* possibly because Linux threads is itself a malloc client */ - /* and can't deal with the signals. */ -# endif -# ifdef __ELF__ -# define DYNAMIC_LOADING -# ifdef UNDEFINED /* includes ro data */ - extern int _etext; -# define DATASTART ((ptr_t)((((word) (&_etext)) + 0xfff) & ~0xfff)) -# endif -# include <features.h> -# if defined(__GLIBC__) && __GLIBC__ >= 2 -# define LINUX_DATA_START -# else - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ -# endif - extern int _end; -# define DATAEND (&_end) -# else - extern int etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) -# endif -# ifdef USE_I686_PREFETCH -# define PREFETCH(x) \ - __asm__ __volatile__ (" prefetchnta %0": : "m"(*(char *)(x))) - /* Empirically prefetcht0 is much more effective at reducing */ - /* cache miss stalls for the targetted load instructions. But it */ - /* seems to interfere enough with other cache traffic that the net */ - /* result is worse than prefetchnta. */ -# if 0 - /* Using prefetches for write seems to have a slight negative */ - /* impact on performance, at least for a PIII/500. */ -# define PREFETCH_FOR_WRITE(x) \ - __asm__ __volatile__ (" prefetcht0 %0": : "m"(*(char *)(x))) -# endif -# endif -# ifdef USE_3DNOW_PREFETCH -# define PREFETCH(x) \ - __asm__ __volatile__ (" prefetch %0": : "m"(*(char *)(x))) -# define PREFETCH_FOR_WRITE(x) - __asm__ __volatile__ (" prefetchw %0": : "m"(*(char *)(x))) -# endif -# endif -# ifdef CYGWIN32 -# define OS_TYPE "CYGWIN32" - extern int _data_start__; - extern int _data_end__; - extern int _bss_start__; - extern int _bss_end__; - /* For binutils 2.9.1, we have */ - /* DATASTART = _data_start__ */ - /* DATAEND = _bss_end__ */ - /* whereas for some earlier versions it was */ - /* DATASTART = _bss_start__ */ - /* DATAEND = _data_end__ */ - /* To get it right for both, we take the */ - /* minumum/maximum of the two. */ -# define MAX(x,y) ((x) > (y) ? (x) : (y)) -# define MIN(x,y) ((x) < (y) ? (x) : (y)) -# define DATASTART ((ptr_t) MIN(&_data_start__, &_bss_start__)) -# define DATAEND ((ptr_t) MAX(&_data_end__, &_bss_end__)) -# undef STACK_GRAN -# define STACK_GRAN 0x10000 -# define HEURISTIC1 -# endif -# ifdef OS2 -# define OS_TYPE "OS2" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. OS2 actually has the right */ - /* system call! */ -# define DATAEND /* not needed */ -# endif -# ifdef MSWIN32 -# define OS_TYPE "MSWIN32" - /* STACKBOTTOM and DATASTART are handled specially in */ - /* os_dep.c. */ -# ifndef __WATCOMC__ -# define MPROTECT_VDB -# endif -# define DATAEND /* not needed */ -# endif -# ifdef DJGPP -# define OS_TYPE "DJGPP" -# include "stubinfo.h" - extern int etext; - extern int _stklen; - extern int __djgpp_stack_limit; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ff) & ~0x1ff)) -/* # define STACKBOTTOM ((ptr_t)((word) _stubinfo + _stubinfo->size \ - + _stklen)) */ -# define STACKBOTTOM ((ptr_t)((word) __djgpp_stack_limit + _stklen)) - /* This may not be right. */ -# endif -# ifdef OPENBSD -# define OS_TYPE "OPENBSD" -# endif -# ifdef FREEBSD -# define OS_TYPE "FREEBSD" -# define MPROTECT_VDB -# endif -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# endif -# ifdef THREE86BSD -# define OS_TYPE "THREE86BSD" -# endif -# ifdef BSDI -# define OS_TYPE "BSDI" -# endif -# if defined(OPENBSD) || defined(FREEBSD) || defined(NETBSD) \ - || defined(THREE86BSD) || defined(BSDI) -# define HEURISTIC2 - extern char etext; -# define DATASTART ((ptr_t)(&etext)) -# endif -# ifdef NEXT -# define OS_TYPE "NEXT" -# define DATASTART ((ptr_t) get_etext()) -# define STACKBOTTOM ((ptr_t)0xc0000000) -# define DATAEND /* not needed */ -# endif -# ifdef DOS4GW -# define OS_TYPE "DOS4GW" - extern long __nullarea; - extern char _end; - extern char *_STACKTOP; - /* Depending on calling conventions Watcom C either precedes - or does not precedes with undescore names of C-variables. - Make sure startup code variables always have the same names. */ - #pragma aux __nullarea "*"; - #pragma aux _end "*"; -# define STACKBOTTOM ((ptr_t) _STACKTOP) - /* confused? me too. */ -# define DATASTART ((ptr_t) &__nullarea) -# define DATAEND ((ptr_t) &_end) -# endif -# ifdef GNU -# define OS_TYPE "GNU" -# endif -# endif - -# ifdef NS32K -# define MACH_TYPE "NS32K" -# define ALIGNMENT 4 - extern char **environ; -# define DATASTART ((ptr_t)(&environ)) - /* hideous kludge: environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ -# define STACKBOTTOM ((ptr_t) 0xfffff000) /* for Encore */ -# endif - -# ifdef MIPS -# define MACH_TYPE "MIPS" -# ifdef LINUX -# define CPP_WORDSZ _MIPS_SZPTR -# define OS_TYPE "LINUX" -# define ALIGNMENT 4 -# define ALIGN_DOUBLE - extern int _fdata; -# define DATASTART ((ptr_t)(&_fdata)) - extern int _end; -# define DATAEND ((ptr_t)(&_end)) -# define STACKBOTTOM ((ptr_t)0x7fff8000) -# define USE_GENERIC_PUSH_REGS 1 -# define DYNAMIC_LOADING -# endif /* Linux */ -# ifdef ULTRIX -# define HEURISTIC2 -# define DATASTART (ptr_t)0x10000000 - /* Could probably be slightly higher since */ - /* startup code allocates lots of stuff. */ -# define OS_TYPE "ULTRIX" -# define ALIGNMENT 4 -# endif -# ifdef RISCOS -# define HEURISTIC2 -# define DATASTART (ptr_t)0x10000000 -# define OS_TYPE "RISCOS" -# define ALIGNMENT 4 /* Required by hardware */ -# endif -# ifdef IRIX5 -# define HEURISTIC2 - extern int _fdata; -# define DATASTART ((ptr_t)(&_fdata)) -# ifdef USE_MMAP -# define HEAP_START (ptr_t)0x30000000 -# else -# define HEAP_START DATASTART -# endif - /* Lowest plausible heap address. */ - /* In the MMAP case, we map there. */ - /* In either case it is used to identify */ - /* heap sections so they're not */ - /* considered as roots. */ -# define OS_TYPE "IRIX5" -# define MPROTECT_VDB -# ifdef _MIPS_SZPTR -# define CPP_WORDSZ _MIPS_SZPTR -# define ALIGNMENT (_MIPS_SZPTR/8) -# if CPP_WORDSZ != 64 -# define ALIGN_DOUBLE -# endif -# else -# define ALIGNMENT 4 -# define ALIGN_DOUBLE -# endif -# define DYNAMIC_LOADING -# endif -# endif - -# ifdef RS6000 -# define MACH_TYPE "RS6000" -# define ALIGNMENT 4 -# define DATASTART ((ptr_t)0x20000000) - extern int errno; -# define STACKBOTTOM ((ptr_t)((ulong)&errno)) -# define DYNAMIC_LOADING - /* For really old versions of AIX, this may have to be removed. */ -# endif - -# ifdef HP_PA - /* OS is assumed to be HP/UX */ -# define MACH_TYPE "HP_PA" -# define OS_TYPE "HPUX" -# ifdef __LP64__ -# define CPP_WORDSZ 64 -# define ALIGNMENT 8 -# else -# define CPP_WORDSZ 32 -# define ALIGNMENT 4 -# define ALIGN_DOUBLE -# endif - extern int __data_start; -# define DATASTART ((ptr_t)(&__data_start)) -# if 0 - /* The following appears to work for 7xx systems running HP/UX */ - /* 9.xx Furthermore, it might result in much faster */ - /* collections than HEURISTIC2, which may involve scanning */ - /* segments that directly precede the stack. It is not the */ - /* default, since it may not work on older machine/OS */ - /* combinations. (Thanks to Raymond X.T. Nijssen for uncovering */ - /* this.) */ -# define STACKBOTTOM ((ptr_t) 0x7b033000) /* from /etc/conf/h/param.h */ -# else - /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */ - /* to this. We'll probably do this on other platforms, too. */ - /* For now I'll use it where I can test it. */ - extern char ** environ; -# define STACKBOTTOM ((ptr_t)environ) -# endif -# ifndef SCM_STACK_GROWS_UP /* don't fight with scmconfig.h */ -# define SCM_STACK_GROWS_UP 1 -# endif -# define DYNAMIC_LOADING -# ifndef HPUX_THREADS -# define MPROTECT_VDB -# endif -# include <unistd.h> -# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE) -# endif - -# ifdef ALPHA -# define MACH_TYPE "ALPHA" -# define ALIGNMENT 8 -# define USE_GENERIC_PUSH_REGS - /* Gcc and probably the DEC/Compaq compiler spill pointers to preserved */ - /* fp registers in some cases when the target is a 21264. The assembly */ - /* code doesn't handle that yet, and version dependencies make that a */ - /* bit tricky. Do the easy thing for now. */ -# ifdef OSF1 -# define OS_TYPE "OSF1" -# define DATASTART ((ptr_t) 0x140000000) - extern _end; -# define DATAEND ((ptr_t) &_end) -# define HEURISTIC2 - /* Normally HEURISTIC2 is too conervative, since */ - /* the text segment immediately follows the stack. */ - /* Hence we give an upper pound. */ - extern int __start; -# define HEURISTIC2_LIMIT ((ptr_t)((word)(&__start) & ~(getpagesize()-1))) -# define CPP_WORDSZ 64 -# define MPROTECT_VDB -# define DYNAMIC_LOADING -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define CPP_WORDSZ 64 -# define STACKBOTTOM ((ptr_t) 0x120000000) -# ifdef __ELF__ -# define LINUX_DATA_START -# define DYNAMIC_LOADING - /* This doesn't work if the collector is in a dynamic library. */ -# else -# define DATASTART ((ptr_t) 0x140000000) -# endif - extern int _end; -# define DATAEND (&_end) -# define MPROTECT_VDB - /* Has only been superficially tested. May not */ - /* work on all versions. */ -# endif -# endif - -# ifdef IA64 -# define MACH_TYPE "IA64" -# define ALIGN_DOUBLE - /* Requires 16 byte alignment for malloc */ -# define ALIGNMENT 8 -# define USE_GENERIC_PUSH_REGS - /* We need to get preserved registers in addition to register windows. */ - /* That's easiest to do with setjmp. */ -# ifdef HPUX - --> needs work -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define CPP_WORDSZ 64 - /* This should really be done through /proc, but that */ - /* requires we run on an IA64 kernel. */ -# define STACKBOTTOM ((ptr_t) 0xa000000000000000l) - /* We also need the base address of the register stack */ - /* backing store. There is probably a better way to */ - /* get that, too ... */ -# define BACKING_STORE_BASE ((ptr_t) 0x9fffffff80000000l) -# if 1 -# define SEARCH_FOR_DATA_START -# define DATASTART GC_data_start -# else - extern int data_start; -# define DATASTART ((ptr_t)(&data_start)) -# endif -# define DYNAMIC_LOADING -# define MPROTECT_VDB - /* Requires Linux 2.3.47 or later. */ - extern int _end; -# define DATAEND (&_end) -# define PREFETCH(x) \ - __asm__ (" lfetch [%0]": : "r"((void *)(x))) -# define PREFETCH_FOR_WRITE(x) \ - __asm__ (" lfetch.excl [%0]": : "r"((void *)(x))) -# define CLEAR_DOUBLE(x) \ - __asm__ (" stf.spill [%0]=f0": : "r"((void *)(x))) -# endif -# endif - -# ifdef M88K -# define MACH_TYPE "M88K" -# define ALIGNMENT 4 -# define ALIGN_DOUBLE - extern int etext; -# ifdef CX_UX -# define OS_TYPE "CX_UX" -# define DATASTART ((((word)&etext + 0x3fffff) & ~0x3fffff) + 0x10000) -# endif -# ifdef DGUX -# define OS_TYPE "DGUX" - extern char * GC_SysVGetDataStart(); -# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext) -# endif -# define STACKBOTTOM ((char*)0xf0000000) /* determined empirically */ -# endif - -# ifdef S370 -# define MACH_TYPE "S370" -# define OS_TYPE "UTS4" -# define ALIGNMENT 4 /* Required by hardware */ - extern int etext; - extern int _etext; - extern int _end; - extern char * GC_SysVGetDataStart(); -# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext) -# define DATAEND (&_end) -# define HEURISTIC2 -# endif - -# if defined(PJ) -# define ALIGNMENT 4 - extern int _etext; -# define DATASTART ((ptr_t)(&_etext)) -# define HEURISTIC1 -# endif - -# ifdef ARM32 -# define CPP_WORDSZ 32 -# define MACH_TYPE "ARM32" -# define ALIGNMENT 4 -# ifdef NETBSD -# define OS_TYPE "NETBSD" -# define HEURISTIC2 - extern char etext; -# define DATASTART ((ptr_t)(&etext)) -# define USE_GENERIC_PUSH_REGS -# endif -# ifdef LINUX -# define OS_TYPE "LINUX" -# define HEURISTIC1 -# undef STACK_GRAN -# define STACK_GRAN 0x10000000 -# define USE_GENERIC_PUSH_REGS -# ifdef __ELF__ -# define DYNAMIC_LOADING -# include <features.h> -# if defined(__GLIBC__) && __GLIBC__ >= 2 -# define LINUX_DATA_START -# else - extern char **__environ; -# define DATASTART ((ptr_t)(&__environ)) - /* hideous kludge: __environ is the first */ - /* word in crt0.o, and delimits the start */ - /* of the data segment, no matter which */ - /* ld options were passed through. */ - /* We could use _etext instead, but that */ - /* would include .rodata, which may */ - /* contain large read-only data tables */ - /* that we'd rather not scan. */ -# endif - extern int _end; -# define DATAEND (&_end) -# else - extern int etext; -# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff)) -# endif -# endif -#endif - -#ifdef LINUX_DATA_START - /* Some Linux distributions arrange to define __data_start. Some */ - /* define data_start as a weak symbol. The latter is technically */ - /* broken, since the user program may define data_start, in which */ - /* case we lose. Nonetheless, we try both, prefering __data_start. */ - /* We assume gcc. */ -# pragma weak __data_start - extern int __data_start; -# pragma weak data_start - extern int data_start; -# define DATASTART ((ptr_t)(&__data_start != 0? &__data_start : &data_start)) -#endif - -# if SCM_STACK_GROWS_UP -# define STACK_GROWS_DOWN 0 -# else -# define STACK_GROWS_DOWN 1 -#endif - -# ifndef CPP_WORDSZ -# define CPP_WORDSZ 32 -# endif - -# ifndef OS_TYPE -# define OS_TYPE "" -# endif - -# ifndef DATAEND - extern int end; -# define DATAEND (&end) -# endif - -# if defined(SVR4) && !defined(GETPAGESIZE) -# include <unistd.h> -# define GETPAGESIZE() sysconf(_SC_PAGESIZE) -# endif - -# ifndef GETPAGESIZE -# if defined(SUNOS5) || defined(IRIX5) -# include <unistd.h> -# endif -# define GETPAGESIZE() getpagesize() -# endif - -# if defined(SUNOS5) || defined(DRSNX) || defined(UTS4) - /* OS has SVR4 generic features. Probably others also qualify. */ -# define SVR4 -# endif - -# if defined(SUNOS5) || defined(DRSNX) - /* OS has SUNOS5 style semi-undocumented interface to dynamic */ - /* loader. */ -# define SUNOS5DL - /* OS has SUNOS5 style signal handlers. */ -# define SUNOS5SIGS -# endif - -# if defined(HPUX) -# define SUNOS5SIGS -# endif - -# if CPP_WORDSZ != 32 && CPP_WORDSZ != 64 - -> bad word size -# endif - -# ifdef PCR -# undef DYNAMIC_LOADING -# undef STACKBOTTOM -# undef HEURISTIC1 -# undef HEURISTIC2 -# undef PROC_VDB -# undef MPROTECT_VDB -# define PCR_VDB -# endif - -# ifdef SRC_M3 -/* Postponed for now. */ -# undef PROC_VDB -# undef MPROTECT_VDB -# endif - -# ifdef SMALL_CONFIG -/* Presumably not worth the space it takes. */ -# undef PROC_VDB -# undef MPROTECT_VDB -# endif - -# ifdef USE_MUNMAP -# undef MPROTECT_VDB /* Can't deal with address space holes. */ -# endif - -# if !defined(PCR_VDB) && !defined(PROC_VDB) && !defined(MPROTECT_VDB) -# define DEFAULT_VDB -# endif - -# ifndef PREFETCH -# define PREFETCH(x) -# define NO_PREFETCH -# endif - -# ifndef PREFETCH_FOR_WRITE -# define PREFETCH_FOR_WRITE(x) -# define NO_PREFETCH_FOR_WRITE -# endif - -# ifndef CACHE_LINE_SIZE -# define CACHE_LINE_SIZE 32 /* Wild guess */ -# endif - -# ifndef CLEAR_DOUBLE -# define CLEAR_DOUBLE(x) \ - ((word*)x)[0] = 0; \ - ((word*)x)[1] = 0; -# endif /* CLEAR_DOUBLE */ - -# if defined(_SOLARIS_PTHREADS) && !defined(SOLARIS_THREADS) -# define SOLARIS_THREADS -# endif -# if defined(IRIX_THREADS) && !defined(IRIX5) ---> inconsistent configuration -# endif -# if defined(IRIX_JDK_THREADS) && !defined(IRIX5) ---> inconsistent configuration -# endif -# if defined(LINUX_THREADS) && !defined(LINUX) ---> inconsistent configuration -# endif -# if defined(SOLARIS_THREADS) && !defined(SUNOS5) ---> inconsistent configuration -# endif -# if defined(HPUX_THREADS) && !defined(HPUX) ---> inconsistent configuration -# endif -# if defined(PCR) || defined(SRC_M3) || \ - defined(SOLARIS_THREADS) || defined(WIN32_THREADS) || \ - defined(IRIX_THREADS) || defined(LINUX_THREADS) || \ - defined(IRIX_JDK_THREADS) || defined(HPUX_THREADS) -# define THREADS -# endif - -# if defined(HP_PA) || defined(M88K) || defined(POWERPC) \ - || (defined(I386) && defined(OS2)) || defined(UTS4) || defined(LINT) - /* Use setjmp based hack to mark from callee-save registers. */ -# define USE_GENERIC_PUSH_REGS -# endif -# if defined(SPARC) && !defined(LINUX) -# define SAVE_CALL_CHAIN -# define ASM_CLEAR_CODE /* Stack clearing is crucial, and we */ - /* include assembly code to do it well. */ -# endif - -# if defined(LINUX) && !defined(POWERPC) - -# if 0 -# include <linux/version.h> -# if (LINUX_VERSION_CODE <= 0x10400) - /* Ugly hack to get struct sigcontext_struct definition. Required */ - /* for some early 1.3.X releases. Will hopefully go away soon. */ - /* in some later Linux releases, asm/sigcontext.h may have to */ - /* be included instead. */ -# define __KERNEL__ -# include <asm/signal.h> -# undef __KERNEL__ -# endif - -# else - - /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */ - /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */ - /* prototypes, so we have to include the top-level sigcontext.h to */ - /* make sure the former gets defined to be the latter if appropriate. */ -# include <features.h> -# if 2 <= __GLIBC__ -# if 2 == __GLIBC__ && 0 == __GLIBC_MINOR__ - /* glibc 2.1 no longer has sigcontext.h. But signal.h */ - /* has the right declaration for glibc 2.1. */ -# include <sigcontext.h> -# endif /* 0 == __GLIBC_MINOR__ */ -# else /* not 2 <= __GLIBC__ */ - /* libc5 doesn't have <sigcontext.h>: go directly with the kernel */ - /* one. Check LINUX_VERSION_CODE to see which we should reference. */ -# include <asm/sigcontext.h> -# endif /* 2 <= __GLIBC__ */ -# endif -# endif -# if !defined(OS2) && !defined(PCR) && !defined(AMIGA) && !defined(MACOS) -# include <sys/types.h> -# if !defined(MSWIN32) && !defined(SUNOS4) -# include <unistd.h> -# endif -# endif - -# include <signal.h> - -/* Blatantly OS dependent routines, except for those that are related */ -/* to dynamic loading. */ - -# if !defined(THREADS) && !defined(STACKBOTTOM) && defined(HEURISTIC2) -# define NEED_FIND_LIMIT -# endif - -# if defined(IRIX_THREADS) || defined(HPUX_THREADS) -# define NEED_FIND_LIMIT -# endif - -# if (defined(SUNOS4) && defined(DYNAMIC_LOADING)) && !defined(PCR) -# define NEED_FIND_LIMIT -# endif - -# if (defined(SVR4) || defined(AUX) || defined(DGUX)) && !defined(PCR) -# define NEED_FIND_LIMIT -# endif - -# if defined(LINUX) && \ - (defined(POWERPC) || defined(SPARC) || defined(ALPHA) || defined(IA64) \ - || defined(MIPS)) -# define NEED_FIND_LIMIT -# endif - -#ifdef NEED_FIND_LIMIT -# include <setjmp.h> -#endif - -#ifdef FREEBSD -# include <machine/trap.h> -#endif - -#ifdef AMIGA -# include <proto/exec.h> -# include <proto/dos.h> -# include <dos/dosextens.h> -# include <workbench/startup.h> -#endif - -#ifdef MSWIN32 -# define WIN32_LEAN_AND_MEAN -# define NOSERVICE -# include <windows.h> -#endif - -#ifdef MACOS -# include <Processes.h> -#endif - -#ifdef IRIX5 -# include <sys/uio.h> -# include <malloc.h> /* for locking */ -#endif -#ifdef USE_MMAP -# include <sys/types.h> -# include <sys/mman.h> -# include <sys/stat.h> -# include <fcntl.h> -#endif - -#ifdef SUNOS5SIGS -# include <sys/siginfo.h> -# undef setjmp -# undef longjmp -# define setjmp(env) sigsetjmp(env, 1) -# define longjmp(env, val) siglongjmp(env, val) -# define jmp_buf sigjmp_buf -#endif - -#ifdef DJGPP - /* Apparently necessary for djgpp 2.01. May casuse problems with */ - /* other versions. */ - typedef long unsigned int caddr_t; -#endif - -#ifdef PCR -# include "il/PCR_IL.h" -# include "th/PCR_ThCtl.h" -# include "mm/PCR_MM.h" -#endif - -#if !defined(NO_EXECUTE_PERMISSION) -# define OPT_PROT_EXEC PROT_EXEC -#else -# define OPT_PROT_EXEC 0 -#endif - -# ifdef OS2 - -# include <stddef.h> - -# if !defined(__IBMC__) && !defined(__WATCOMC__) /* e.g. EMX */ - -# else /* IBM's compiler */ - -/* A kludge to get around what appears to be a header file bug */ -# ifndef WORD -# define WORD unsigned short -# endif -# ifndef DWORD -# define DWORD unsigned long -# endif - -# define EXE386 1 -# include <newexe.h> -# include <exe386.h> - -# endif /* __IBMC__ */ - -# define INCL_DOSEXCEPTIONS -# define INCL_DOSPROCESS -# define INCL_DOSERRORS -# define INCL_DOSMODULEMGR -# define INCL_DOSMEMMGR -# include <os2.h> - -# endif /*!OS/2 */ - -/* - * Find the base of the stack. - * Used only in single-threaded environment. - * With threads, GC_mark_roots needs to know how to do this. - * Called with allocator lock held. - */ -# ifdef MSWIN32 -# define is_writable(prot) ((prot) == PAGE_READWRITE \ - || (prot) == PAGE_WRITECOPY \ - || (prot) == PAGE_EXECUTE_READWRITE \ - || (prot) == PAGE_EXECUTE_WRITECOPY) -/* Return the number of bytes that are writable starting at p. */ -/* The pointer p is assumed to be page aligned. */ -/* If base is not 0, *base becomes the beginning of the */ -/* allocation region containing p. */ -static word GC_get_writable_length(ptr_t p, ptr_t *base) -{ - MEMORY_BASIC_INFORMATION buf; - word result; - word protect; - - result = VirtualQuery(p, &buf, sizeof(buf)); - if (result != sizeof(buf)) ABORT("Weird VirtualQuery result"); - if (base != 0) *base = (ptr_t)(buf.AllocationBase); - protect = (buf.Protect & ~(PAGE_GUARD | PAGE_NOCACHE)); - if (!is_writable(protect)) { - return(0); - } - if (buf.State != MEM_COMMIT) return(0); - return(buf.RegionSize); -} - -void *scm_get_stack_base() -{ - int dummy; - ptr_t sp = (ptr_t)(&dummy); - ptr_t trunc_sp; - word size; - static word GC_page_size = 0; - if (!GC_page_size) { - SYSTEM_INFO sysinfo; - GetSystemInfo(&sysinfo); - GC_page_size = sysinfo.dwPageSize; - } - trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1)); - size = GC_get_writable_length(trunc_sp, 0); - return(trunc_sp + size); -} - - -# else - -# ifdef OS2 - -void *scm_get_stack_base() -{ - PTIB ptib; - PPIB ppib; - - if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) { - GC_err_printf0("DosGetInfoBlocks failed\n"); - ABORT("DosGetInfoBlocks failed\n"); - } - return((ptr_t)(ptib -> tib_pstacklimit)); -} - -# else - -# ifdef AMIGA - -void *scm_get_stack_base() -{ - struct Process *proc = (struct Process*)SysBase->ThisTask; - - /* Reference: Amiga Guru Book Pages: 42,567,574 */ - if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS - && proc->pr_CLI != NULL) { - /* first ULONG is StackSize */ - /*longPtr = proc->pr_ReturnAddr; - size = longPtr[0];*/ - - return (char *)proc->pr_ReturnAddr + sizeof(ULONG); - } else { - return (char *)proc->pr_Task.tc_SPUpper; - } -} - -#if 0 /* old version */ -void *scm_get_stack_base() -{ - extern struct WBStartup *_WBenchMsg; - extern long __base; - extern long __stack; - struct Task *task; - struct Process *proc; - struct CommandLineInterface *cli; - long size; - - if ((task = FindTask(0)) == 0) { - GC_err_puts("Cannot find own task structure\n"); - ABORT("task missing"); - } - proc = (struct Process *)task; - cli = BADDR(proc->pr_CLI); - - if (_WBenchMsg != 0 || cli == 0) { - size = (char *)task->tc_SPUpper - (char *)task->tc_SPLower; - } else { - size = cli->cli_DefaultStack * 4; - } - return (ptr_t)(__base + GC_max(size, __stack)); -} -#endif /* 0 */ - -# else /* !AMIGA, !OS2, ... */ - -# ifdef NEED_FIND_LIMIT - /* Some tools to implement HEURISTIC2 */ -# define MIN_PAGE_SIZE 256 /* Smallest conceivable page size, bytes */ - /* static */ jmp_buf GC_jmp_buf; - - /*ARGSUSED*/ - static void GC_fault_handler(sig) - int sig; - { - longjmp(GC_jmp_buf, 1); - } - -# ifdef __STDC__ - typedef void (*handler)(int); -# else - typedef void (*handler)(); -# endif - -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) - static struct sigaction old_segv_act; -# if defined(_sigargs) || defined(HPUX) /* !Irix6.x */ - static struct sigaction old_bus_act; -# endif -# else - static handler old_segv_handler, old_bus_handler; -# endif - - static void GC_setup_temporary_fault_handler() - { -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) - struct sigaction act; - - act.sa_handler = GC_fault_handler; - act.sa_flags = SA_RESTART | SA_NODEFER; - /* The presence of SA_NODEFER represents yet another gross */ - /* hack. Under Solaris 2.3, siglongjmp doesn't appear to */ - /* interact correctly with -lthread. We hide the confusion */ - /* by making sure that signal handling doesn't affect the */ - /* signal mask. */ - - (void) sigemptyset(&act.sa_mask); -# ifdef IRIX_THREADS - /* Older versions have a bug related to retrieving and */ - /* and setting a handler at the same time. */ - (void) sigaction(SIGSEGV, 0, &old_segv_act); - (void) sigaction(SIGSEGV, &act, 0); -# else - (void) sigaction(SIGSEGV, &act, &old_segv_act); -# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ - || defined(HPUX) - /* Under Irix 5.x or HP/UX, we may get SIGBUS. */ - /* Pthreads doesn't exist under Irix 5.x, so we */ - /* don't have to worry in the threads case. */ - (void) sigaction(SIGBUS, &act, &old_bus_act); -# endif -# endif /* IRIX_THREADS */ -# else - old_segv_handler = signal(SIGSEGV, GC_fault_handler); -# ifdef SIGBUS - old_bus_handler = signal(SIGBUS, GC_fault_handler); -# endif -# endif - } - - static void GC_reset_fault_handler() - { -# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1) - (void) sigaction(SIGSEGV, &old_segv_act, 0); -# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \ - || defined(HPUX) - (void) sigaction(SIGBUS, &old_bus_act, 0); -# endif -# else - (void) signal(SIGSEGV, old_segv_handler); -# ifdef SIGBUS - (void) signal(SIGBUS, old_bus_handler); -# endif -# endif - } - - /* Single argument version, robust against whole program analysis. */ - static void - GC_noop1(x) - word x; - { - static VOLATILE word sink; - sink = x; - } - - /* Return the first nonaddressible location > p (up) or */ - /* the smallest location q s.t. [q,p] is addressible (!up). */ - static ptr_t GC_find_limit(p, up) - ptr_t p; - GC_bool up; - { - static VOLATILE ptr_t result; - /* Needs to be static, since otherwise it may not be */ - /* preserved across the longjmp. Can safely be */ - /* static since it's only called once, with the */ - /* allocation lock held. */ - - - GC_setup_temporary_fault_handler(); - if (setjmp(GC_jmp_buf) == 0) { - result = (ptr_t)(((word)(p)) - & ~(MIN_PAGE_SIZE-1)); - for (;;) { - if (up) { - result += MIN_PAGE_SIZE; - } else { - result -= MIN_PAGE_SIZE; - } - GC_noop1((word)(*result)); - } - } - GC_reset_fault_handler(); - if (!up) { - result += MIN_PAGE_SIZE; - } - return(result); - } - -# endif - -#ifdef LINUX_STACKBOTTOM - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -# define STAT_SKIP 27 /* Number of fields preceding startstack */ - /* field in /proc/self/stat */ - - static ptr_t GC_linux_stack_base(void) - { - /* We read the stack base value from /proc/self/stat. We do this */ - /* using direct I/O system calls in order to avoid calling malloc */ - /* in case REDIRECT_MALLOC is defined. */ -# define STAT_BUF_SIZE 4096 -# ifdef USE_LD_WRAP -# define STAT_READ __real_read -# else -# define STAT_READ read -# endif - char stat_buf[STAT_BUF_SIZE]; - int f; - char c; - word result = 0; - size_t i, buf_offset = 0; - - f = open("/proc/self/stat", O_RDONLY); - if (f < 0 || STAT_READ(f, stat_buf, STAT_BUF_SIZE) < 2 * STAT_SKIP) { - ABORT("Couldn't read /proc/self/stat"); - } - c = stat_buf[buf_offset++]; - /* Skip the required number of fields. This number is hopefully */ - /* constant across all Linux implementations. */ - for (i = 0; i < STAT_SKIP; ++i) { - while (isspace(c)) c = stat_buf[buf_offset++]; - while (!isspace(c)) c = stat_buf[buf_offset++]; - } - while (isspace(c)) c = stat_buf[buf_offset++]; - while (isdigit(c)) { - result *= 10; - result += c - '0'; - c = stat_buf[buf_offset++]; - } - close(f); - if (result < 0x10000000) ABORT("Absurd stack bottom value"); - return (ptr_t)result; - } - -#endif /* LINUX_STACKBOTTOM */ - -void *scm_get_stack_base() -{ - word dummy; - void *result; - - result = &dummy; /* initialize to silence compiler */ - -# define STACKBOTTOM_ALIGNMENT_M1 ((word)STACK_GRAN - 1) - -# ifdef STACKBOTTOM - return(STACKBOTTOM); -# else -# ifdef HEURISTIC1 -# if STACK_GROWS_DOWN - result = (ptr_t)((((word)(&dummy)) - + STACKBOTTOM_ALIGNMENT_M1) - & ~STACKBOTTOM_ALIGNMENT_M1); -# else - result = (ptr_t)(((word)(&dummy)) - & ~STACKBOTTOM_ALIGNMENT_M1); -# endif -# endif /* HEURISTIC1 */ -# ifdef LINUX_STACKBOTTOM - result = GC_linux_stack_base(); -# endif -# ifdef HEURISTIC2 -# if STACK_GROWS_DOWN - result = GC_find_limit((ptr_t)(&dummy), TRUE); -# ifdef HEURISTIC2_LIMIT - if (result > HEURISTIC2_LIMIT - && (ptr_t)(&dummy) < HEURISTIC2_LIMIT) { - result = HEURISTIC2_LIMIT; - } -# endif -# else - result = GC_find_limit((ptr_t)(&dummy), FALSE); -# ifdef HEURISTIC2_LIMIT - if (result < HEURISTIC2_LIMIT - && (ptr_t)(&dummy) > HEURISTIC2_LIMIT) { - result = HEURISTIC2_LIMIT; - } -# endif -# endif - -# endif /* HEURISTIC2 */ -# if STACK_GROWS_DOWN - if (result == 0) result = (ptr_t)(signed_word)(-sizeof(ptr_t)); -# endif - return(result); -# endif /* STACKBOTTOM */ -} - -# endif /* ! AMIGA */ -# endif /* ! OS2 */ -# endif /* ! MSWIN32 */ - -#endif /* mach_type_known */ -#endif /* ! HAVE_LIBC_STACK_END */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c index bd4ccb375..19ecfdf0d 100644 --- a/libguile/gdbint.c +++ b/libguile/gdbint.c @@ -101,55 +101,26 @@ int gdb_output_length; int scm_print_carefully_p; static SCM gdb_input_port; -static int port_mark_p, stream_mark_p, string_mark_p; - static SCM gdb_output_port; -static void -unmark_port (SCM port) -{ - SCM stream, string; - port_mark_p = SCM_GC_MARK_P (port); - SCM_CLEAR_GC_MARK (port); - stream = SCM_PACK (SCM_STREAM (port)); - stream_mark_p = SCM_GC_MARK_P (stream); - SCM_CLEAR_GC_MARK (stream); - string = SCM_CDR (stream); - string_mark_p = SCM_GC_MARK_P (string); - SCM_CLEAR_GC_MARK (string); -} - - -static void -remark_port (SCM port) -{ - SCM stream = SCM_PACK (SCM_STREAM (port)); - SCM string = SCM_CDR (stream); - if (string_mark_p) - SCM_SET_GC_MARK (string); - if (stream_mark_p) - SCM_SET_GC_MARK (stream); - if (port_mark_p) - SCM_SET_GC_MARK (port); -} - - int gdb_maybe_valid_type_p (SCM value) { - return SCM_IMP (value) || scm_in_heap_p (value); + return SCM_IMP (value); /* || scm_in_heap_p (value); */ /* FIXME: What to + do? */ } int gdb_read (char *str) { +#if 0 SCM ans; int status = 0; RESET_STRING; /* Need to be restrictive about what to read? */ - if (SCM_GC_P) + if (1) /* (SCM_GC_P) */ /* FIXME */ { char *p; for (p = str; *p != '\0'; ++p) @@ -201,6 +172,9 @@ exit: remark_port (gdb_input_port); SCM_END_FOREIGN_BLOCK; return status; +#else + abort (); +#endif } diff --git a/libguile/goops.c b/libguile/goops.c index c09932c08..72579b881 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -733,9 +733,8 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, ls = SCM_CDR (ls); } flags &= SCM_CLASSF_INHERIT; - if (flags & SCM_CLASSF_ENTITY) - SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity); - else + + if (! (flags & SCM_CLASSF_ENTITY)) { long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields)); #if 0 @@ -752,7 +751,6 @@ SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0, { /* NOTE: The following depends on scm_struct_i_size. */ flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */ - SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); } } SCM_SET_CLASS_FLAGS (class, flags); @@ -2809,7 +2807,6 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, } else if (size > 0) { - SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light); SCM_SET_CLASS_INSTANCE_SIZE (class, size); } diff --git a/libguile/guardians.c b/libguile/guardians.c index 5a7c76045..879462a73 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -16,7 +16,6 @@ */ - /* This is an implementation of guardians as described in * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on @@ -37,6 +36,9 @@ * Now they should again behave like those described in the paper. * Scheme guardians should be simple and friendly, not like the greedy * monsters we had... + * + * Rewritten for the Boehm-Wiser GC by Ludovic Courtès. + * FIXME: This is currently not thread-safe. */ @@ -53,180 +55,187 @@ #include "libguile/eval.h" #include "libguile/guardians.h" +#include "libguile/boehm-gc.h" -/* The live and zombies FIFOs are implemented as tconcs as described - in Dybvig's paper. This decouples addition and removal of elements - so that no synchronization between these needs to take place. -*/ - -typedef struct t_tconc -{ - SCM head; - SCM tail; -} t_tconc; - -#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail)) - -#define TCONC_IN(tc, obj, pair) \ -do { \ - SCM_SETCAR ((tc).tail, obj); \ - SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \ - SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \ - SCM_SETCDR ((tc).tail, pair); \ - (tc).tail = pair; \ -} while (0) - -#define TCONC_OUT(tc, res) \ -do { \ - (res) = SCM_CAR ((tc).head); \ - (tc).head = SCM_CDR ((tc).head); \ -} while (0) static scm_t_bits tc16_guardian; typedef struct t_guardian { - t_tconc live; - t_tconc zombies; + unsigned long live; + SCM zombies; struct t_guardian *next; } t_guardian; #define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x) #define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x)) -static t_guardian *guardians; -void -scm_i_init_guardians_for_gc () -{ - guardians = NULL; -} -/* mark a guardian by adding it to the live guardian list. */ -static SCM -guardian_mark (SCM ptr) -{ - t_guardian *g = GUARDIAN_DATA (ptr); - g->next = guardians; - guardians = g; - - return SCM_BOOL_F; -} -/* Identify inaccessible objects and move them from the live list to - the zombie list. An object is inaccessible when it is unmarked at - this point. Therefore, the inaccessible objects are not marked yet - since that would prevent them from being recognized as - inaccessible. - - The pairs that form the life list itself are marked, tho. -*/ -void -scm_i_identify_inaccessible_guardeds () +static int +guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) { - t_guardian *g; + t_guardian *g = GUARDIAN_DATA (guardian); + + scm_puts ("#<guardian ", port); + scm_uintprint ((scm_t_bits) g, 16, port); - for (g = guardians; g; g = g->next) - { - SCM pair, next_pair; - SCM *prev_ptr; + scm_puts (" (reachable: ", port); + scm_display (scm_from_uint (g->live), port); + scm_puts (" unreachable: ", port); + scm_display (scm_length (g->zombies), port); + scm_puts (")", port); - for (pair = g->live.head, prev_ptr = &g->live.head; - !scm_is_eq (pair, g->live.tail); - pair = next_pair) - { - SCM obj = SCM_CAR (pair); - next_pair = SCM_CDR (pair); - if (!SCM_GC_MARK_P (obj)) - { - /* Unmarked, move to 'inaccessible' list. - */ - *prev_ptr = next_pair; - TCONC_IN (g->zombies, obj, pair); - } - else - { - SCM_SET_GC_MARK (pair); - prev_ptr = SCM_CDRLOC (pair); - } - } - SCM_SET_GC_MARK (pair); - } + scm_puts (">", port); + + return 1; } -int -scm_i_mark_inaccessible_guardeds () +/* Handle finalization of OBJ which is guarded by the guardians listed in + GUARDIAN_LIST. */ +static void +finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data) { - t_guardian *g; - int again = 0; + SCM cell_pool; + SCM obj, guardian_list, proxied_finalizer; - /* We never need to see the guardians again that are processed here, - so we clear the list. Calling scm_gc_mark below might find new - guardians, however (and other things), and we inform the GC about - this by returning non-zero. See scm_mark_all in gc-mark.c - */ + obj = PTR2SCM (ptr); + guardian_list = SCM_CDR (PTR2SCM (finalizer_data)); + proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data)); - g = guardians; - guardians = NULL; +#if 0 + printf ("finalizing guarded %p (%u guardians)\n", + ptr, scm_to_uint (scm_length (guardian_list))); +#endif - for (; g; g = g->next) + /* Preallocate a bunch of cells so that we can make sure that no garbage + collection (and, thus, nested calls to `finalize_guarded ()') occurs + while executing the following loop. This is quite inefficient (call to + `scm_length ()') but that shouldn't be a problem in most cases. */ + cell_pool = scm_make_list (scm_length (guardian_list), SCM_UNSPECIFIED); + + /* Tell each guardian interested in OBJ that OBJ is no longer + reachable. */ + for (; + guardian_list != SCM_EOL; + guardian_list = SCM_CDR (guardian_list)) { - SCM pair; + SCM zombies; + t_guardian *g; - for (pair = g->zombies.head; - !scm_is_eq (pair, g->zombies.tail); - pair = SCM_CDR (pair)) - { - if (!SCM_GC_MARK_P (pair)) - { - scm_gc_mark (SCM_CAR (pair)); - SCM_SET_GC_MARK (pair); - again = 1; - } - } - SCM_SET_GC_MARK (pair); + if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list)) + /* The guardian itself vanished in the meantime. */ + continue; + + g = GUARDIAN_DATA (SCM_CAR (guardian_list)); + if (g->live == 0) + abort (); + + /* Get a fresh cell from CELL_POOL. */ + zombies = cell_pool; + cell_pool = SCM_CDR (cell_pool); + + /* Compute and update G's zombie list. */ + SCM_SETCAR (zombies, SCM_PACK (obj)); + SCM_SETCDR (zombies, g->zombies); + g->zombies = zombies; + + g->live--; + g->zombies = zombies; } - return again; -} -static size_t -guardian_free (SCM ptr) -{ - scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian"); - return 0; -} + if (proxied_finalizer != SCM_BOOL_F) + { + /* Re-register the finalizer that was in place before we installed this + one. */ + GC_finalization_proc finalizer, prev_finalizer; + GC_PTR finalizer_data, prev_finalizer_data; -static int -guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - t_guardian *g = GUARDIAN_DATA (guardian); - - scm_puts ("#<guardian ", port); - scm_uintprint ((scm_t_bits) g, 16, port); + finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer)); + finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer)); - scm_puts (" (reachable: ", port); - scm_display (scm_length (SCM_CDR (g->live.head)), port); - scm_puts (" unreachable: ", port); - scm_display (scm_length (SCM_CDR (g->zombies.head)), port); - scm_puts (")", port); + if (finalizer == NULL) + abort (); - scm_puts (">", port); + GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data, + &prev_finalizer, &prev_finalizer_data); - return 1; +#if 0 + printf (" reinstalled proxied finalizer %p for %p\n", finalizer, ptr); +#endif + } + +#if 0 + printf ("end of finalize (%p)\n", ptr); +#endif } +/* Add OBJ as a guarded object of GUARDIAN. */ static void scm_i_guard (SCM guardian, SCM obj) { t_guardian *g = GUARDIAN_DATA (guardian); - - if (!SCM_IMP (obj)) + + if (SCM_NIMP (obj)) { - SCM z; - z = scm_cons (SCM_BOOL_F, SCM_BOOL_F); - TCONC_IN (g->live, obj, z); + /* Register a finalizer and pass a pair as the ``client data'' + argument. The pair contains in its car `#f' or a pair describing a + ``proxied'' finalizer (see below); its cdr contains a list of + guardians interested in OBJ. + + A ``proxied'' finalizer is a finalizer that was registered for OBJ + before OBJ became guarded (e.g., a SMOB `free' function). We are + assuming here that finalizers are only used internally, either at + the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB') + or by this function. */ + GC_finalization_proc prev_finalizer; + GC_PTR prev_data; + SCM guardians_for_obj, finalizer_data; + + g->live++; + + /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be + collected before the objects it guards (see `guardians.test'). */ + guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL); + finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj); + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded, + SCM2PTR (finalizer_data), + &prev_finalizer, &prev_data); + + if (prev_finalizer == finalize_guarded) + { + /* OBJ is already guarded by another guardian: add GUARDIAN to its + list of guardians. */ + SCM prev_guardian_list, prev_finalizer_data; + + if (prev_data == NULL) + abort (); + + prev_finalizer_data = PTR2SCM (prev_data); + if (!scm_is_pair (prev_finalizer_data)) + abort (); + + prev_guardian_list = SCM_CDR (prev_finalizer_data); + SCM_SETCDR (guardians_for_obj, prev_guardian_list); + + /* Also copy information about proxied finalizers. */ + SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data)); + } + else if (prev_finalizer != NULL) + { + /* There was already a finalizer registered for OBJ so we will + ``proxy'' it, i.e., record it so that we can re-register it once + `finalize_guarded ()' has finished. */ + SCM proxied_finalizer; + + proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer), + PTR2SCM (prev_data)); + SCM_SETCAR (finalizer_data, proxied_finalizer); + } } } @@ -236,8 +245,12 @@ scm_i_get_one_zombie (SCM guardian) t_guardian *g = GUARDIAN_DATA (guardian); SCM res = SCM_BOOL_F; - if (!TCONC_EMPTYP (g->zombies)) - TCONC_OUT (g->zombies, res); + if (g->zombies != SCM_EOL) + { + /* Note: We return zombies in reverse order. */ + res = SCM_CAR (g->zombies); + g->zombies = SCM_CDR (g->zombies); + } return res; } @@ -314,13 +327,11 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, #define FUNC_NAME s_scm_make_guardian { t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian"); - SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL); - SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL); SCM z; /* A tconc starts out with one tail pair. */ - g->live.head = g->live.tail = z1; - g->zombies.head = g->zombies.tail = z2; + g->live = 0; + g->zombies = SCM_EOL; g->next = NULL; @@ -333,9 +344,11 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0, void scm_init_guardians () { + /* We use unordered finalization `a la Java. */ + GC_java_finalization = 1; + tc16_guardian = scm_make_smob_type ("guardian", 0); - scm_set_smob_mark (tc16_guardian, guardian_mark); - scm_set_smob_free (tc16_guardian, guardian_free); + scm_set_smob_print (tc16_guardian, guardian_print); #if ENABLE_DEPRECATED scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 2d28d65b7..08209613a 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -30,6 +30,8 @@ #include "libguile/validate.h" #include "libguile/hashtab.h" + + /* NOTES @@ -78,8 +80,99 @@ static unsigned long hashtable_size[] = { static char *s_hashtable = "hashtable"; -SCM weak_hashtables = SCM_EOL; + +/* Helper functions and macros to deal with weak pairs. + + Weak pairs need to be accessed very carefully since their components can + be nullified by the GC when the object they refer to becomes unreachable. + Hence the macros and functions below that detect such weak pairs within + buckets and remove them. */ + + +/* Return a ``usable'' version of ALIST, an alist of weak pairs. By + ``usable'', we mean that it contains only valid Scheme objects. On + return, REMOVE_ITEMS is set to the number of pairs that have been + deleted. */ +static SCM +scm_fixup_weak_alist (SCM alist, size_t *removed_items) +{ + SCM result; + SCM prev = SCM_EOL; + + *removed_items = 0; + for (result = alist; + scm_is_pair (alist); + prev = alist, alist = SCM_CDR (alist)) + { + SCM pair = SCM_CAR (alist); + + if (scm_is_pair (pair)) + { + if (SCM_WEAK_PAIR_DELETED_P (pair)) + { + /* Remove from ALIST weak pair PAIR whose car/cdr has been + nullified by the GC. */ + if (prev == SCM_EOL) + result = SCM_CDR (alist); + else + SCM_SETCDR (prev, SCM_CDR (alist)); + + (*removed_items)++; + continue; + } + } + } + + return result; +} + + +/* Helper macros. */ + +/* Return true if OBJ is either a weak hash table or a weak alist vector (as + defined in `weaks.[ch]'). + FIXME: We should eventually keep only weah hash tables. Actually, the + procs in `weaks.c' already no longer return vectors. */ +/* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */ +#define IS_WEAK_THING(_obj) \ + ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \ + || (SCM_I_IS_VECTOR (table))) + + + +/* Fixup BUCKET, an alist part of weak hash table OBJ. BUCKETS is the full + bucket vector for OBJ and IDX is the index of BUCKET within this + vector. See also `scm_internal_hash_fold ()'. */ +#define START_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \ +do \ + { \ + size_t _removed; \ + \ + /* Disable the GC so that BUCKET remains valid until ASSOC_FN has \ + returned. */ \ + /* FIXME: We could maybe trigger a rehash here depending on whether \ + `scm_fixup_weak_alist ()' noticed some change. */ \ + GC_disable (); \ + (_bucket) = scm_fixup_weak_alist ((_bucket), &_removed); \ + SCM_SIMPLE_VECTOR_SET ((_buckets), (_idx), (_bucket)); \ + \ + if ((_removed) && (SCM_HASHTABLE_P (_obj))) \ + { \ + SCM_SET_HASHTABLE_N_ITEMS ((_obj), \ + SCM_HASHTABLE_N_ITEMS (_obj) - _removed); \ + scm_i_rehash ((_obj), (_hashfn), \ + NULL, "START_WEAK_BUCKET_FIXUP"); \ + } \ + } \ +while (0) + +/* Terminate a weak bucket fixup phase. */ +#define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \ + do { GC_enable (); } while (0) + + + static SCM make_hash_table (int flags, unsigned long k, const char *func_name) { @@ -89,24 +182,22 @@ make_hash_table (int flags, unsigned long k, const char *func_name) while (i < HASHTABLE_SIZE_N && n > hashtable_size[i]) ++i; n = hashtable_size[i]; - if (flags) - vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL); - else - vector = scm_c_make_vector (n, SCM_EOL); - t = scm_gc_malloc (sizeof (*t), s_hashtable); + + /* In both cases, i.e., regardless of whether we are creating a weak hash + table, we return a non-weak vector. This is because the vector itself + is not weak in the case of a weak hash table: the alist pairs are. */ + vector = scm_c_make_vector (n, SCM_EOL); + + t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable); t->min_size_index = t->size_index = i; t->n_items = 0; t->lower = 0; t->upper = 9 * n / 10; t->flags = flags; t->hash_fn = NULL; - if (flags) - { - SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables); - weak_hashtables = table; - } - else - SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL); + + SCM_NEWSMOB2 (table, scm_tc16_hashtable, vector, t); + return table; } @@ -153,13 +244,8 @@ scm_i_rehash (SCM table, SCM_HASHTABLE (table)->lower = new_size / 4; SCM_HASHTABLE (table)->upper = 9 * new_size / 10; buckets = SCM_HASHTABLE_VECTOR (table); - - if (SCM_HASHTABLE_WEAK_P (table)) - new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table), - scm_from_ulong (new_size), - SCM_EOL); - else - new_buckets = scm_c_make_vector (new_size, SCM_EOL); + + new_buckets = scm_c_make_vector (new_size, SCM_EOL); /* When this is a weak hashtable, running the GC might change it. We need to cope with this while rehashing its elements. We do @@ -182,9 +268,15 @@ scm_i_rehash (SCM table, while (scm_is_pair (ls)) { unsigned long h; + cell = ls; handle = SCM_CAR (cell); ls = SCM_CDR (ls); + + if (SCM_WEAK_PAIR_DELETED_P (handle)) + /* HANDLE is a nullified weak pair: skip it. */ + continue; + h = hash_fn (SCM_CAR (handle), new_size, closure); if (h >= new_size) scm_out_of_range (func_name, scm_from_ulong (h)); @@ -215,79 +307,6 @@ hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } -/* keep track of hash tables that need to shrink after scan */ -static SCM to_rehash = SCM_EOL; - -/* scan hash tables and update hash tables item count */ -void -scm_i_scan_weak_hashtables () -{ - SCM *next = &weak_hashtables; - SCM h = *next; - while (!scm_is_null (h)) - { - if (!SCM_GC_MARK_P (h)) - *next = h = SCM_HASHTABLE_NEXT (h); - else - { - SCM vec = SCM_HASHTABLE_VECTOR (h); - size_t delta = SCM_I_WVECT_DELTA (vec); - SCM_I_SET_WVECT_DELTA (vec, 0); - SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta); - - if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h)) - { - SCM tmp = SCM_HASHTABLE_NEXT (h); - /* temporarily move table from weak_hashtables to to_rehash */ - SCM_SET_HASHTABLE_NEXT (h, to_rehash); - to_rehash = h; - *next = h = tmp; - } - else - { - next = SCM_HASHTABLE_NEXTLOC (h); - h = SCM_HASHTABLE_NEXT (h); - } - } - } -} - -static void * -rehash_after_gc (void *dummy1 SCM_UNUSED, - void *dummy2 SCM_UNUSED, - void *dummy3 SCM_UNUSED) -{ - if (!scm_is_null (to_rehash)) - { - SCM first = to_rehash, last, h; - /* important to clear to_rehash here so that we don't get stuck - in an infinite loop if scm_i_rehash causes GC */ - to_rehash = SCM_EOL; - h = first; - do - { - /* Rehash only when we have a hash_fn. - */ - if (SCM_HASHTABLE (h)->hash_fn) - scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL, - "rehash_after_gc"); - last = h; - h = SCM_HASHTABLE_NEXT (h); - } while (!scm_is_null (h)); - /* move tables back to weak_hashtables */ - SCM_SET_HASHTABLE_NEXT (last, weak_hashtables); - weak_hashtables = first; - } - return 0; -} - -static size_t -hashtable_free (SCM obj) -{ - scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable); - return 0; -} - SCM scm_c_make_hash_table (unsigned long k) @@ -411,19 +430,34 @@ SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure) #define FUNC_NAME "scm_hash_fn_get_handle" { + int weak = 0; unsigned long k; - SCM h; + SCM buckets, alist, h; if (SCM_HASHTABLE_P (table)) - table = SCM_HASHTABLE_VECTOR (table); + buckets = SCM_HASHTABLE_VECTOR (table); else - SCM_VALIDATE_VECTOR (1, table); - if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0) + { + SCM_VALIDATE_VECTOR (1, table); + buckets = table; + } + + if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) return SCM_BOOL_F; - k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure); - if (k >= SCM_SIMPLE_VECTOR_LENGTH (table)) + k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); + if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure); + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + h = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + return h; } #undef FUNC_NAME @@ -434,8 +468,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ SCM (*assoc_fn)(), void * closure) #define FUNC_NAME "scm_hash_fn_create_handle_x" { + int weak = 0; unsigned long k; - SCM buckets, it; + SCM buckets, alist, it; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -451,8 +486,17 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k)); - it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); - if (scm_is_pair (it)) + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + it = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + if (scm_is_true (it)) return it; else if (scm_is_true (it)) scm_wrong_type_arg_msg (NULL, 0, it, "a pair"); @@ -464,7 +508,25 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_ again since the hashtable might have been rehashed. This necessitates a new hash value as well. */ - SCM new_bucket = scm_acons (obj, init, SCM_EOL); + SCM handle, new_bucket; + + if ((SCM_HASHTABLE_P (table)) && (SCM_HASHTABLE_WEAK_P (table))) + { + /* FIXME: We don't support weak alist vectors. */ + /* Use a weak cell. */ + if (SCM_HASHTABLE_DOUBLY_WEAK_P (table)) + handle = scm_doubly_weak_pair (obj, init); + else if (SCM_HASHTABLE_WEAK_KEY_P (table)) + handle = scm_weak_car_pair (obj, init); + else + handle = scm_weak_cdr_pair (obj, init); + } + else + /* Use a regular, non-weak cell. */ + handle = scm_cons (obj, init); + + new_bucket = scm_cons (handle, SCM_EOL); + if (!scm_is_eq (table, buckets) && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets)) { @@ -519,14 +581,15 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(), } -SCM +SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void *closure) { + int weak = 0; unsigned long k; - SCM buckets, h; + SCM buckets, alist, h; if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); @@ -542,7 +605,16 @@ scm_hash_fn_remove_x (SCM table, SCM obj, k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k)); - h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); + + weak = IS_WEAK_THING (table); + alist = SCM_SIMPLE_VECTOR_REF (buckets, k); + if (weak) + START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + + h = assoc_fn (obj, alist, closure); + if (weak) + END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn); + if (scm_is_true (h)) { SCM_SIMPLE_VECTOR_SET @@ -917,21 +989,47 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) if (SCM_HASHTABLE_P (table)) buckets = SCM_HASHTABLE_VECTOR (table); else + /* Weak alist vector. */ buckets = table; n = SCM_SIMPLE_VECTOR_LENGTH (buckets); for (i = 0; i < n; ++i) { - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; - while (!scm_is_null (ls)) + SCM prev, ls; + + for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i); + !scm_is_null (ls); + prev = ls, ls = SCM_CDR (ls)) { + SCM handle; + if (!scm_is_pair (ls)) scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + handle = SCM_CAR (ls); if (!scm_is_pair (handle)) scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + + if (IS_WEAK_THING (table)) + { + if (SCM_WEAK_PAIR_DELETED_P (handle)) + { + /* We hit a weak pair whose car/cdr has become + unreachable: unlink it from the bucket. */ + if (prev != SCM_BOOL_F) + SCM_SETCDR (prev, SCM_CDR (ls)); + else + SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls)); + + if (SCM_HASHTABLE_P (table)) + /* Update the item count. */ + SCM_HASHTABLE_DECREMENT (table); + + continue; + } + } + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); - ls = SCM_CDR (ls); } } @@ -1066,11 +1164,9 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, void scm_hashtab_prehistory () { + /* Initialize the hashtab SMOB type. */ scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0); - scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr); scm_set_smob_print (scm_tc16_hashtable, hashtable_print); - scm_set_smob_free (scm_tc16_hashtable, hashtable_free); - scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0); } void diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 4220b8668..005fd57aa 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -39,9 +39,6 @@ SCM_API scm_t_bits scm_tc16_hashtable; #define SCM_HASHTABLE_VECTOR(h) SCM_SMOB_OBJECT (h) #define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_SMOB_OBJECT ((x), (v)) #define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_SMOB_DATA_2 (x)) -#define SCM_HASHTABLE_NEXT(x) SCM_SMOB_OBJECT_3 (x) -#define SCM_HASHTABLE_NEXTLOC(x) SCM_SMOB_OBJECT_3_LOC (x) -#define SCM_SET_HASHTABLE_NEXT(x, n) SCM_SET_SMOB_OBJECT_3 ((x), (n)) #define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags) #define SCM_HASHTABLE_WEAK_KEY_P(x) \ (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR) @@ -98,7 +95,6 @@ SCM_API SCM scm_doubly_weak_hash_table_p (SCM h); SCM_INTERNAL void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char *func_name); -SCM_INTERNAL void scm_i_scan_weak_hashtables (void); SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure); diff --git a/libguile/hooks.c b/libguile/hooks.c index 7d1dae30e..787382983 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -290,7 +290,6 @@ void scm_init_hooks () { scm_tc16_hook = scm_make_smob_type ("hook", 0); - scm_set_smob_mark (scm_tc16_hook, scm_markcdr); scm_set_smob_print (scm_tc16_hook, hook_print); #include "libguile/hooks.x" } diff --git a/libguile/init.c b/libguile/init.c index 25cff62a5..d9d75242c 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -433,7 +433,9 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_ports_prehistory (); scm_smob_prehistory (); scm_fluids_prehistory (); - scm_hashtab_prehistory (); /* requires storage_prehistory */ + scm_weaks_prehistory (); + scm_hashtab_prehistory (); /* requires storage_prehistory, and + weaks_prehistory */ #ifdef GUILE_DEBUG_MALLOC scm_debug_malloc_prehistory (); #endif diff --git a/libguile/inline.h b/libguile/inline.h index f3c76b5e2..3fae97c17 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -76,6 +76,9 @@ "inline.c", when `inline' is not supported at all or when "extern inline" is used. */ +#include "libguile/boehm-gc.h" + + SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr); SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, scm_t_bits ccr, scm_t_bits cdr); @@ -105,65 +108,20 @@ extern unsigned scm_newcell_count; #ifndef SCM_INLINE_C_INCLUDING_INLINE_H SCM_C_EXTERN_INLINE #endif + SCM scm_cell (scm_t_bits car, scm_t_bits cdr) { - SCM z; - SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist); + SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell)))); - if (scm_is_null (*freelist)) - z = scm_gc_for_newcell (&scm_i_master_freelist, freelist); - else - { - z = *freelist; - *freelist = SCM_FREE_CELL_CDR (*freelist); - } + /* Initialize the type slot last so that the cell is ignored by the GC + until it is completely initialized. This is only relevant when the GC + can actually run during this code, which it can't since the GC only runs + when all other threads are stopped. */ + SCM_GC_SET_CELL_WORD (cell, 1, cdr); + SCM_GC_SET_CELL_WORD (cell, 0, car); -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_debug_cell_accesses_p) - { - if (SCM_GC_MARK_P (z)) - { - fprintf(stderr, "scm_cell tried to allocate a marked cell.\n"); - abort(); - } - else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell) - { - fprintf(stderr, "cell from freelist is not a free cell.\n"); - abort(); - } - } - -#if (SCM_DEBUG_MARKING_API == 0) - /* - Always set mark. Otherwise cells that are alloced before - scm_debug_cell_accesses_p is toggled seem invalid. - */ - SCM_SET_GC_MARK (z); -#endif /* SCM_DEBUG_MARKING_API */ - - /* - TODO: figure out if this use of mark bits is valid with - threading. What if another thread is doing GC at this point - ... ? - */ -#endif - - - /* Initialize the type slot last so that the cell is ignored by the - GC until it is completely initialized. This is only relevant - when the GC can actually run during this code, which it can't - since the GC only runs when all other threads are stopped. - */ - SCM_GC_SET_CELL_WORD (z, 1, cdr); - SCM_GC_SET_CELL_WORD (z, 0, car); - -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_expensive_debug_cell_accesses_p ) - scm_i_expensive_validation_check (z); -#endif - - return z; + return cell; } #ifndef SCM_INLINE_C_INCLUDING_INLINE_H @@ -174,16 +132,8 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, scm_t_bits ccr, scm_t_bits cdr) { SCM z; - SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2); - - if (scm_is_null (*freelist)) - z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist); - else - { - z = *freelist; - *freelist = SCM_FREE_CELL_CDR (*freelist); - } + z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell)))); /* Initialize the type slot last so that the cell is ignored by the GC until it is completely initialized. This is only relevant when the GC can actually run during this code, which it can't @@ -194,23 +144,6 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, SCM_GC_SET_CELL_WORD (z, 3, cdr); SCM_GC_SET_CELL_WORD (z, 0, car); -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_debug_cell_accesses_p) - { - if (SCM_GC_MARK_P (z)) - { - fprintf(stderr, - "scm_double_cell tried to allocate a marked cell.\n"); - abort(); - } - } -#if (SCM_DEBUG_MARKING_API == 0) - /* see above. */ - SCM_SET_GC_MARK (z); -#endif /* SCM_DEBUG_MARKING_API */ - -#endif - /* When this function is inlined, it's possible that the last SCM_GC_SET_CELL_WORD above will be adjacent to a following initialization of z. E.g., it occurred in scm_make_real. GCC diff --git a/libguile/keywords.c b/libguile/keywords.c index 045537a55..831c2cc28 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -111,7 +111,6 @@ void scm_init_keywords () { scm_tc16_keyword = scm_make_smob_type ("keyword", 0); - scm_set_smob_mark (scm_tc16_keyword, scm_markcdr); scm_set_smob_print (scm_tc16_keyword, keyword_print); scm_keyword_obarray = scm_c_make_hash_table (0); diff --git a/libguile/macros.c b/libguile/macros.c index db279ec7e..1e2a12ef6 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -239,7 +239,6 @@ void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, scm_markcdr); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" } diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 6a68b96e7..0c7d45053 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -41,14 +41,6 @@ scm_t_bits scm_tc16_malloc; -static size_t -malloc_free (SCM ptr) -{ - if (SCM_MALLOCDATA (ptr)) - free (SCM_MALLOCDATA (ptr)); - return 0; -} - static int malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -71,11 +63,10 @@ scm_malloc_obj (size_t n) -void +void scm_init_mallocs () { scm_tc16_malloc = scm_make_smob_type ("malloc", 0); - scm_set_smob_free (scm_tc16_malloc, malloc_free); scm_set_smob_print (scm_tc16_malloc, malloc_print); } diff --git a/libguile/modules.c b/libguile/modules.c index 168fbce60..e524eb518 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -774,8 +774,18 @@ SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0, while (!scm_is_null (ls)) { handle = SCM_CAR (ls); - if (SCM_CDR (handle) == variable) - return SCM_CAR (handle); + + if (SCM_CAR (handle) == SCM_PACK (NULL)) + { + /* FIXME: We hit a weak pair whose car has become unreachable. + We should remove the pair in question or something. */ + } + else + { + if (SCM_CDR (handle) == variable) + return SCM_CAR (handle); + } + ls = SCM_CDR (ls); } } @@ -835,7 +845,6 @@ scm_init_modules () module_make_local_var_x_var = scm_c_define ("module-make-local-var!", SCM_UNDEFINED); scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0); - scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr); scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0); the_module = scm_permanent_object (scm_make_fluid ()); diff --git a/libguile/numbers.c b/libguile/numbers.c index 20eb16a26..3c54f61ed 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5328,8 +5328,9 @@ scm_c_make_rectangular (double re, double im) else { SCM z; - SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex), - "complex")); + SCM_NEWSMOB (z, scm_tc16_complex, + scm_gc_malloc_pointerless (sizeof (scm_t_complex), + "complex")); SCM_COMPLEX_REAL (z) = re; SCM_COMPLEX_IMAG (z) = im; return z; diff --git a/libguile/objects.c b/libguile/objects.c index 649d08fe2..c02741abe 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -346,7 +346,6 @@ scm_init_objects () scm_c_define ("<operator-class>", ot); scm_metaclass_operator = ot; SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY); - SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity); scm_c_define ("<entity>", et); #include "libguile/objects.x" diff --git a/libguile/ports.c b/libguile/ports.c index b25a7d007..04cb83ad0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -29,6 +29,8 @@ #include <errno.h> #include <fcntl.h> /* for chsize on mingw */ +#include <assert.h> + #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/eval.h" @@ -54,10 +56,6 @@ #include <string.h> #endif -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - #ifdef HAVE_IO_H #include <io.h> #endif @@ -138,9 +136,11 @@ scm_make_port_type (char *name, if (255 <= scm_numptob) goto ptoberr; SCM_CRITICAL_SECTION_START; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, - (1 + scm_numptob) - * sizeof (scm_t_ptob_descriptor))); + tmp = (char *) scm_gc_realloc ((char *) scm_ptobs, + scm_numptob * sizeof (scm_t_ptob_descriptor), + (1 + scm_numptob) + * sizeof (scm_t_ptob_descriptor), + "port-type"); if (tmp) { scm_ptobs = (scm_t_ptob_descriptor *) tmp; @@ -495,8 +495,70 @@ SCM scm_i_port_weak_hash; scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; -/* This function is not and should not be thread safe. */ + +/* Port finalization. */ + + +static void finalize_port (GC_PTR, GC_PTR); + +/* Register a finalizer for PORT, if needed by its port type. */ +static SCM_C_INLINE_KEYWORD void +register_finalizer_for_port (SCM port) +{ + long port_type; + + port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port)); + if (scm_ptobs[port_type].free) + { + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalization_data; + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0, + &prev_finalizer, + &prev_finalization_data); + } +} + +/* Finalize the object (a port) pointed to by PTR. */ +static void +finalize_port (GC_PTR ptr, GC_PTR data) +{ + long port_type; + SCM port = PTR2SCM (ptr); + + if (!SCM_PORTP (port)) + abort (); + if (SCM_OPENP (port)) + { + if (SCM_REVEALED (port) > 0) + /* Keep "revealed" ports alive and re-register a finalizer. */ + register_finalizer_for_port (port); + else + { + port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port)); + if (port_type >= scm_numptob) + abort (); + + if (scm_ptobs[port_type].free) + /* Yes, I really do mean `.free' rather than `.close'. `.close' + is for explicit `close-port' by user. */ + scm_ptobs[port_type].free (port); + + SCM_SETSTREAM (port, 0); + SCM_CLR_PORT_OPEN_FLAG (port); + scm_remove_from_port_table (port); + + scm_gc_ports_collected++; + } + } +} + + + + + +/* This function is not and should not be thread safe. */ SCM scm_new_port_table_entry (scm_t_bits tag) #define FUNC_NAME "scm_new_port_table_entry" @@ -518,6 +580,10 @@ scm_new_port_table_entry (scm_t_bits tag) scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F); + /* For each new port, register a finalizer so that it port type's free + function can be invoked eventually. */ + register_finalizer_for_port (z); + return z; } #undef FUNC_NAME @@ -1089,10 +1155,11 @@ scm_c_write (SCM port, const void *ptr, size_t size) } #undef FUNC_NAME -void +void scm_flush (SCM port) { long i = SCM_PTOBNUM (port); + assert ((i >= 0) && (i < scm_i_port_table_size)); (scm_ptobs[i].flush) (port); } @@ -1134,6 +1201,8 @@ scm_ungetc (int c, SCM port) { size_t new_size = pt->read_buf_size * 2; unsigned char *tmp = (unsigned char *) + /* XXX: Can we use `GC_REALLOC' with `GC_MALLOC_ATOMIC'-allocated + data? (Ludo) */ scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size, "putback buffer"); @@ -1161,8 +1230,8 @@ scm_ungetc (int c, SCM port) if (pt->putback_buf == NULL) { pt->putback_buf - = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE, - "putback buffer"); + = (unsigned char *) scm_gc_malloc_pointerless + (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer"); pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE; } @@ -1577,7 +1646,14 @@ void scm_ports_prehistory () { scm_numptob = 0; - scm_ptobs = (scm_t_ptob_descriptor *) scm_malloc (sizeof (scm_t_ptob_descriptor)); + scm_ptobs = NULL; + + /* In order for the ports to be collectable, the port table must not be + scanned by the GC. */ + scm_i_port_table = + scm_gc_malloc_pointerless (scm_i_port_table_room + * sizeof (scm_t_port *), + "port-table"); } diff --git a/libguile/print.c b/libguile/print.c index fb9a74ef2..3064fa1bd 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -629,16 +629,30 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) last = pstate->length - 1; cutp = 1; } - for (i = 0; i < last; ++i) + if (SCM_I_WVECTP (exp)) { - /* CHECK_INTS; */ - scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); - scm_putc (' ', port); + /* Elements of weak vectors may not be accessed via the + `SIMPLE_VECTOR_REF ()' macro. */ + for (i = 0; i < last; ++i) + { + scm_iprin1 (scm_c_vector_ref (exp, i), + port, pstate); + scm_putc (' ', port); + } + } + else + { + for (i = 0; i < last; ++i) + { + scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); + scm_putc (' ', port); + } } + if (i == last) { /* CHECK_INTS; */ - scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); + scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate); } if (cutp) scm_puts (" ...", port); @@ -795,7 +809,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) { scm_puts ("#<unknown-", port); scm_puts (hdr, port); - if (scm_in_heap_p (ptr)) + if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */ { scm_puts (" (0x", port); scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port); @@ -1187,7 +1201,6 @@ scm_init_print () /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */ scm_tc16_port_with_ps = scm_make_smob_type (0, 0); - scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr); scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print); #include "libguile/print.x" diff --git a/libguile/private-gc.h b/libguile/private-gc.h index 93503ceb1..00bef9d2e 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -83,67 +83,6 @@ int scm_getenv_int (const char *var, int def); typedef enum { return_on_error, abort_on_error } policy_on_error; -/* gc-freelist */ - -/* - FREELIST: - - A struct holding GC statistics on a particular type of cells. - - Counts in cells are mainly for heap statistics, and for - double-cells, they are still measured in single-cell units. -*/ -typedef struct scm_t_cell_type_statistics { - /* - heap segment where the last cell was allocated - */ - int heap_segment_idx; - - /* defines min_yield as fraction of total heap size - */ - float min_yield_fraction; - - /* number of cells per object on this list */ - int span; - - /* number of collected cells during last GC. */ - unsigned long collected; - - unsigned long swept; - - /* - Total number of cells in heap segments belonging to this list. - */ - unsigned long heap_total_cells; -} scm_t_cell_type_statistics; - - -/* Sweep statistics. */ -typedef struct scm_sweep_statistics -{ - /* Number of cells "swept", i.e., visited during the sweep operation. */ - unsigned swept; - - /* Number of cells collected during the sweep operation. This number must - always be lower than or equal to SWEPT. */ - unsigned collected; -} scm_t_sweep_statistics; - -SCM_INTERNAL scm_t_sweep_statistics scm_i_gc_sweep_stats; - - -extern scm_t_cell_type_statistics scm_i_master_freelist; -extern scm_t_cell_type_statistics scm_i_master_freelist2; - -SCM_INTERNAL -void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist, - scm_t_sweep_statistics sweep_stats, - scm_t_sweep_statistics sweep_stats_1); -SCM_INTERNAL -void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist); -SCM_INTERNAL float -scm_i_gc_heap_size_delta (scm_t_cell_type_statistics * freelist); - #define SCM_MAX(A, B) ((A) > (B) ? (A) : (B)) #define SCM_MIN(A, B) ((A) < (B) ? (A) : (B)) @@ -170,109 +109,6 @@ int scm_i_marking; void scm_mark_all (void); -/* -gc-segment: -*/ - -/* - - Cells are stored in a heap-segment: it is a contiguous chunk of - memory, that associated with one freelist. -*/ -typedef struct scm_t_heap_segment -{ - /* - {lower, upper} bounds of the segment - - The upper bound is also the start of the mark space. - */ - scm_t_cell *bounds[2]; - - /* - If we ever decide to give it back, we could do it with this ptr. - - Note that giving back memory is not very useful; as long we don't - touch a chunk of memory, the virtual memory system will keep it - swapped out. We could simply forget about a block. - - (not that we do that, but anyway.) - */ - void *malloced; - - scm_t_cell *next_free_card; - - /* address of the head-of-freelist pointer for this segment's cells. - All segments usually point to the same one, scm_i_freelist. */ - scm_t_cell_type_statistics *freelist; - - /* number of cells per object in this segment */ - int span; - - /* - Is this the first time that the cells are accessed? - */ - int first_time; -} scm_t_heap_segment; - -/* - A table of segment records is kept that records the upper and - lower extents of the segment; this is used during the conservative - phase of gc to identify probably gc roots (because they point - into valid segments at reasonable offsets). -*/ -extern scm_t_heap_segment ** scm_i_heap_segment_table; -extern size_t scm_i_heap_segment_table_size; - - -SCM_INTERNAL int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list, - scm_t_heap_segment*); -SCM_INTERNAL int scm_i_sweep_card (scm_t_cell *card, SCM *free_list, - scm_t_heap_segment *); -SCM_INTERNAL int scm_i_card_marked_count (scm_t_cell *card, int span); -SCM_INTERNAL void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, - scm_t_heap_segment *seg); -SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */ - -SCM_INTERNAL int scm_i_initialize_heap_segment_data (scm_t_heap_segment *seg, - size_t requested); - -SCM_INTERNAL int scm_i_segment_cells_per_card (scm_t_heap_segment *seg); -SCM_INTERNAL int scm_i_segment_card_number (scm_t_heap_segment *seg, - scm_t_cell *card); -SCM_INTERNAL int scm_i_segment_card_count (scm_t_heap_segment *seg); -SCM_INTERNAL int scm_i_segment_cell_count (scm_t_heap_segment *seg); -SCM_INTERNAL int scm_i_heap_segment_marked_count (scm_t_heap_segment *seg); - -SCM_INTERNAL void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg); -SCM_INTERNAL scm_t_heap_segment * -scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*); -SCM_INTERNAL SCM scm_i_sweep_for_freelist (scm_t_cell_type_statistics *seg); -SCM_INTERNAL SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg, - scm_t_sweep_statistics *sweep_stats, - int threshold); -SCM_INTERNAL void scm_i_sweep_segment (scm_t_heap_segment *seg, - scm_t_sweep_statistics *sweep_stats); - -SCM_INTERNAL void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, - SCM tab); - - -SCM_INTERNAL int scm_i_insert_segment (scm_t_heap_segment *seg); -SCM_INTERNAL int scm_i_find_heap_segment_containing_object (SCM obj); -SCM_INTERNAL int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist, - size_t length, - policy_on_error); -SCM_INTERNAL int scm_i_marked_count (void); -SCM_INTERNAL void scm_i_clear_mark_space (void); -SCM_INTERNAL void scm_i_sweep_segments (void); -SCM_INTERNAL SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics *fl, - scm_t_sweep_statistics *sweep_stats); -SCM_INTERNAL void scm_i_reset_segments (void); -SCM_INTERNAL void scm_i_sweep_all_segments (char const *reason, - scm_t_sweep_statistics *sweep_stats); -SCM_INTERNAL SCM scm_i_all_segments_statistics (SCM hashtab); -SCM_INTERNAL unsigned long *scm_i_segment_table_info(int *size); - extern long int scm_i_deprecated_memory_return; extern long int scm_i_find_heap_calls; diff --git a/libguile/procs.c b/libguile/procs.c index 2359eae1f..8bf46649b 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -109,20 +109,6 @@ scm_c_define_subr_with_generic (const char *name, return subr; } -void -scm_mark_subr_table () -{ - long i; - for (i = 0; i < scm_subr_table_size; ++i) - { - scm_gc_mark (scm_subr_table[i].name); - if (scm_subr_table[i].generic && *scm_subr_table[i].generic) - scm_gc_mark (*scm_subr_table[i].generic); - if (SCM_NIMP (scm_subr_table[i].properties)) - scm_gc_mark (scm_subr_table[i].properties); - } -} - #ifdef CCLO SCM diff --git a/libguile/procs.h b/libguile/procs.h index cf9cdf182..e8d69cb14 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -136,7 +136,6 @@ SCM_API long scm_subr_table_room; -SCM_API void scm_mark_subr_table (void); SCM_API void scm_free_subr_entry (SCM subr); SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)()); SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type, diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 608a00b85..bd6d4854d 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -28,6 +28,9 @@ #include <pthread.h> #include <sched.h> +/* `libgc' intercepts pthread calls by defining wrapping macros. */ +#include "libguile/boehm-gc.h" + /* Threads */ #define scm_i_pthread_t pthread_t diff --git a/libguile/random.c b/libguile/random.c index 912f6acc5..e4daead8f 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -142,7 +142,10 @@ scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n) scm_t_i_rstate * scm_i_copy_rstate (scm_t_i_rstate *state) { - scm_t_rstate *new_state = scm_malloc (scm_the_rng.rstate_size); + scm_t_rstate *new_state; + + new_state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size, + "random-state"); return memcpy (new_state, state, scm_the_rng.rstate_size); } @@ -154,7 +157,10 @@ scm_i_copy_rstate (scm_t_i_rstate *state) scm_t_rstate * scm_c_make_rstate (const char *seed, int n) { - scm_t_rstate *state = scm_malloc (scm_the_rng.rstate_size); + scm_t_rstate *state; + + state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size, + "random-state"); state->reserved0 = 0; scm_the_rng.init_rstate (state, seed, n); return state; @@ -314,12 +320,6 @@ make_rstate (scm_t_rstate *state) SCM_RETURN_NEWSMOB (scm_tc16_rstate, state); } -static size_t -rstate_free (SCM rstate) -{ - free (SCM_RSTATE (rstate)); - return 0; -} /* * Scheme level interface. @@ -595,7 +595,6 @@ scm_init_random () scm_the_rng = rng; scm_tc16_rstate = scm_make_smob_type ("random-state", 0); - scm_set_smob_free (scm_tc16_rstate, rstate_free); for (m = 1; m <= 0x100; m <<= 1) for (i = m >> 1; i < m; ++i) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index d280c82b6..f8677a1a3 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -172,7 +172,7 @@ SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1, flag = SCM_CDR (flag); } - rx = scm_gc_malloc (sizeof(regex_t), "regex"); + rx = scm_gc_malloc_pointerless (sizeof (regex_t), "regex"); c_pat = scm_to_locale_string (pat); status = regcomp (rx, c_pat, /* Make sure they're not passing REG_NOSUB; diff --git a/libguile/root.h b/libguile/root.h index 11f6b4f3a..a8116c879 100644 --- a/libguile/root.h +++ b/libguile/root.h @@ -35,13 +35,11 @@ #define scm_keyword_obarray scm_sys_protects[4] #define scm_stand_in_procs scm_sys_protects[5] #define scm_object_whash scm_sys_protects[6] -#define scm_permobjs scm_sys_protects[7] -#define scm_asyncs scm_sys_protects[8] -#define scm_protects scm_sys_protects[9] -#define scm_properties_whash scm_sys_protects[10] -#define scm_gc_registered_roots scm_sys_protects[11] -#define scm_source_whash scm_sys_protects[12] -#define SCM_NUM_PROTECTS 13 +#define scm_asyncs scm_sys_protects[7] +#define scm_protects scm_sys_protects[8] +#define scm_properties_whash scm_sys_protects[9] +#define scm_source_whash scm_sys_protects[10] +#define SCM_NUM_PROTECTS 11 SCM_API SCM scm_sys_protects[]; diff --git a/libguile/smob.c b/libguile/smob.c index a728cc78b..718442237 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -37,6 +37,10 @@ #include "libguile/smob.h" +#include "libguile/boehm-gc.h" +#include <gc/gc_mark.h> + + /* scm_smobs scm_numsmob @@ -456,12 +460,13 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), SCM scm_make_smob (scm_t_bits tc) { - long n = SCM_TC2SMOBNUM (tc); + scm_t_bits n = SCM_TC2SMOBNUM (tc); size_t size = scm_smobs[n].size; scm_t_bits data = (size > 0 ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n)) : 0); - return scm_cell (tc, data); + + SCM_RETURN_NEWSMOB (tc, data); } @@ -485,12 +490,155 @@ free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } + +/* Marking SMOBs using user-supplied mark procedures. */ + + +/* The freelist and GC kind used for SMOB types that provide a custom mark + procedure. */ +static void **smob_freelist = NULL; +static int smob_gc_kind = 0; + + +/* The generic SMOB mark procedure that gets called for SMOBs allocated with + `scm_i_new_smob_with_mark_proc ()'. */ +static struct GC_ms_entry * +smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + register SCM cell; + register scm_t_bits tc, smobnum; + + cell = PTR2SCM (addr); + + if (SCM_TYP7 (cell) != scm_tc7_smob) + /* It is likely that the GC passed us a pointer to a free-list element + which we must ignore (see warning in `gc/gc_mark.h'). */ + return mark_stack_ptr; + + tc = SCM_CELL_WORD_0 (cell); + smobnum = SCM_TC2SMOBNUM (tc); + + if (smobnum >= scm_numsmob) + /* The first word looks corrupt. */ + abort (); + + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_3 (cell)), + mark_stack_ptr, + mark_stack_limit, NULL); + + if (scm_smobs[smobnum].mark) + { + SCM obj; + + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; + SCM_I_CURRENT_THREAD->current_mark_stack_limit = mark_stack_limit; + + /* Invoke the SMOB's mark procedure, which will in turn invoke + `scm_gc_mark ()', which may modify `current_mark_stack_ptr'. */ + obj = scm_smobs[smobnum].mark (cell); + + mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr; + + if (SCM_NIMP (obj)) + /* Mark the returned object. */ + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj), + mark_stack_ptr, + mark_stack_limit, NULL); + + SCM_I_CURRENT_THREAD->current_mark_stack_limit = NULL; + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = NULL; + } + + return mark_stack_ptr; + +} + +/* Mark object O. We assume that this function is only called during the + mark phase, i.e., from within `smob_mark ()' or one of its + descendents. */ +void +scm_gc_mark (SCM o) +{ +#define CURRENT_MARK_PTR \ + ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_ptr)) +#define CURRENT_MARK_LIMIT \ + ((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit)) + + if (SCM_NIMP (o)) + { + /* At this point, the `current_mark_*' fields of the current thread + must be defined (they are set in `smob_mark ()'). */ + register struct GC_ms_entry *mark_stack_ptr; + + if (!CURRENT_MARK_PTR) + /* The function was not called from a mark procedure. */ + abort (); + + mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (o), + CURRENT_MARK_PTR, CURRENT_MARK_LIMIT, + NULL); + SCM_I_CURRENT_THREAD->current_mark_stack_ptr = mark_stack_ptr; + } +#undef CURRENT_MARK_PTR +#undef CURRENT_MARK_LIMIT +} + +/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may + provide a custom mark procedure and it will be honored. */ +SCM +scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1, + scm_t_bits data2, scm_t_bits data3) +{ + /* Return a double cell. */ + SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell), + smob_gc_kind)); + + SCM_SET_CELL_WORD_3 (cell, data3); + SCM_SET_CELL_WORD_2 (cell, data2); + SCM_SET_CELL_WORD_1 (cell, data1); + SCM_SET_CELL_WORD_0 (cell, tc); + + return cell; +} + + +/* Finalize SMOB by calling its SMOB type's free function, if any. */ +void +scm_i_finalize_smob (GC_PTR ptr, GC_PTR data) +{ + SCM smob; + size_t (* free_smob) (SCM); + + smob = PTR2SCM (ptr); +#if 0 + printf ("finalizing SMOB %p (smobnum: %u)\n", + ptr, SCM_SMOBNUM (smob)); +#endif + + free_smob = scm_smobs[SCM_SMOBNUM (smob)].free; + if (free_smob) + free_smob (smob); +} + + void scm_smob_prehistory () { long i; scm_t_bits tc; + smob_freelist = GC_new_free_list (); + smob_gc_kind = GC_new_kind ((void **)smob_freelist, + GC_MAKE_PROC (GC_new_proc (smob_mark), 0), + 0, 0); + scm_numsmob = 0; for (i = 0; i < MAX_SMOB_COUNT; ++i) { diff --git a/libguile/smob.h b/libguile/smob.h index a4d70c8be..2bf508e28 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -25,6 +25,9 @@ #include "libguile/__scm.h" #include "libguile/print.h" +#include "libguile/boehm-gc.h" + + /* This is the internal representation of a smob type */ @@ -44,40 +47,77 @@ typedef struct scm_smob_descriptor int gsubr_type; /* Used in procprop.c */ } scm_smob_descriptor; - - -#define SCM_NEWSMOB(z, tc, data) \ -do { \ - z = scm_cell ((tc), (scm_t_bits) (data)); \ -} while (0) -#define SCM_RETURN_NEWSMOB(tc, data) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \ - return __SCM_smob_answer; \ + +SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc, + scm_t_bits, scm_t_bits, scm_t_bits); + + + +#define SCM_NEWSMOB(z, tc, data) \ +do \ + { \ + register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ + z = (scm_smobs[_smobnum].mark \ + ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \ + 0, 0) \ + : scm_cell (tc, (scm_t_bits)(data))); \ + if (scm_smobs[_smobnum].free) \ + { \ + GC_finalization_proc _prev_finalizer; \ + GC_PTR _prev_finalizer_data; \ + \ + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \ + NULL, \ + &_prev_finalizer, \ + &_prev_finalizer_data); \ + } \ + } \ +while (0) + +#define SCM_RETURN_NEWSMOB(tc, data) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \ + return __SCM_smob_answer; \ } while (0) -#define SCM_NEWSMOB2(z, tc, data1, data2) \ -do { \ - z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \ -} while (0) +#define SCM_NEWSMOB2(z, tc, data1, data2) \ + SCM_NEWSMOB3 (z, tc, data1, data2, 0) -#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \ - return __SCM_smob_answer; \ +#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \ + return __SCM_smob_answer; \ } while (0) -#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ -do { \ - z = scm_double_cell ((tc), (scm_t_bits)(data1), \ - (scm_t_bits)(data2), (scm_t_bits)(data3)); \ -} while (0) - -#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ - do { SCM __SCM_smob_answer; \ - SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \ - return __SCM_smob_answer; \ +#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \ +do \ + { \ + register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \ + z = (scm_smobs[_smobnum].mark \ + ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1), \ + (scm_t_bits)(data2), \ + (scm_t_bits)(data3)) \ + : scm_double_cell ((tc), (scm_t_bits)(data1), \ + (scm_t_bits)(data2), \ + (scm_t_bits)(data3))); \ + if (scm_smobs[_smobnum].free) \ + { \ + GC_finalization_proc _prev_finalizer; \ + GC_PTR _prev_finalizer_data; \ + \ + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \ + NULL, \ + &_prev_finalizer, \ + &_prev_finalizer_data); \ + } \ + } \ +while (0) + +#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \ + do { SCM __SCM_smob_answer; \ + SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \ + return __SCM_smob_answer; \ } while (0) @@ -116,6 +156,7 @@ SCM_API long scm_numsmob; SCM_API scm_smob_descriptor scm_smobs[]; SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data); +SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data); diff --git a/libguile/srcprop.c b/libguile/srcprop.c index ed9b1b7fd..ed3612781 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -30,6 +30,7 @@ #include "libguile/ports.h" #include "libguile/root.h" #include "libguile/weaks.h" +#include "libguile/gc.h" #include "libguile/validate.h" #include "libguile/srcprop.h" @@ -208,7 +209,7 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, else if (!scm_is_pair (obj)) SCM_WRONG_TYPE_ARG(1, obj); handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); - SCM_SETCDR (handle, plist); + return plist; } #undef FUNC_NAME diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index 908e0c8ff..fc047c028 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -67,13 +67,6 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) } -/* Smob free hook for character sets. */ -static size_t -charset_free (SCM charset) -{ - return scm_smob_free (charset); -} - /* Create a new, empty character set. */ static SCM @@ -1544,7 +1537,6 @@ scm_init_srfi_14 (void) { scm_tc16_charset = scm_make_smob_type ("character-set", BYTES_PER_CHARSET); - scm_set_smob_free (scm_tc16_charset, charset_free); scm_set_smob_print (scm_tc16_charset, charset_print); scm_char_set_upper_case = define_charset ("char-set:upper-case"); diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 7d22f8b52..940698b46 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -244,34 +244,6 @@ uvec_equalp (SCM a, SCM b) return result; } -/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */ - -#if SCM_HAVE_T_INT64 == 0 -static SCM -uvec_mark (SCM uvec) -{ - if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64 - || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64) - { - SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec); - size_t len = SCM_UVEC_LENGTH (uvec), i; - for (i = 0; i < len; i++) - scm_gc_mark (*ptr++); - } - return SCM_BOOL_F; -} -#endif - -/* Smob free hook for uniform numeric vectors. */ -static size_t -uvec_free (SCM uvec) -{ - int type = SCM_UVEC_TYPE (uvec); - scm_gc_free (SCM_UVEC_BASE (uvec), - SCM_UVEC_LENGTH (uvec) * uvec_sizes[type], - uvec_names[type]); - return 0; -} /* ================================================================ */ /* Utility procedures. */ @@ -1121,10 +1093,6 @@ scm_init_srfi_4 (void) { scm_tc16_uvec = scm_make_smob_type ("uvec", 0); scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); -#if SCM_HAVE_T_INT64 == 0 - scm_set_smob_mark (scm_tc16_uvec, uvec_mark); -#endif - scm_set_smob_free (scm_tc16_uvec, uvec_free); scm_set_smob_print (scm_tc16_uvec, uvec_print); #if SCM_HAVE_T_INT64 == 0 diff --git a/libguile/strings.c b/libguile/strings.c index c9b08a05b..90051bd1b 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -115,7 +115,7 @@ make_stringbuf (size_t len) } else { - char *mem = scm_gc_malloc (len+1, "string"); + char *mem = scm_gc_malloc_pointerless (len + 1, "string"); mem[len] = '\0'; return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem, (scm_t_bits) len, (scm_t_bits) 0); diff --git a/libguile/struct.c b/libguile/struct.c index ad88ac844..e3afd51d7 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -39,6 +39,8 @@ #include <string.h> #endif +#include "libguile/boehm-gc.h" + static SCM required_vtable_fields = SCM_BOOL_F; @@ -304,97 +306,53 @@ scm_alloc_struct (int n_words, int n_extra, const char *what) p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7); /* Initialize a few fields as described above. */ - p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard; + p[scm_struct_i_free] = (scm_t_bits) 0; p[scm_struct_i_ptr] = (scm_t_bits) block; p[scm_struct_i_n_words] = n_words; p[scm_struct_i_flags] = 0; + /* Since `SCM' objects will record either P or P + SCM_TC3_STRUCT, we need + to register them as valid displacements. Fortunately, only a handful of + N_EXTRA values are used in core Guile. */ + GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block); + GC_REGISTER_DISPLACEMENT ((char *)p - (char *)block + scm_tc3_struct); + return p; } -void -scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED, - scm_t_bits * data SCM_UNUSED) -{ -} + +/* Finalization. */ -void -scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data) -{ - size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK; - scm_gc_free (data, n, "struct"); -} -void -scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) +/* Invoke the finalizer of the struct pointed to by PTR. */ +static void +struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data) { - size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words) - * sizeof (scm_t_bits) + 7; - scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct"); -} + SCM obj = PTR2SCM (ptr); -void -scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data) -{ - size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) - * sizeof (scm_t_bits) + 7; - scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct"); -} + /* XXX - use less explicit code. */ + scm_t_bits word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_struct; + scm_t_bits *vtable_data = (scm_t_bits *) word0; + scm_t_bits *data = SCM_STRUCT_DATA (obj); + scm_t_struct_free free_struct_data + = ((scm_t_struct_free) vtable_data[scm_struct_i_free]); -static void * -scm_struct_gc_init (void *dummy1 SCM_UNUSED, - void *dummy2 SCM_UNUSED, - void *dummy3 SCM_UNUSED) -{ - scm_i_structs_to_free = SCM_EOL; - return 0; -} + SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); -static void * -scm_free_structs (void *dummy1 SCM_UNUSED, - void *dummy2 SCM_UNUSED, - void *dummy3 SCM_UNUSED) -{ - SCM newchain = scm_i_structs_to_free; - do - { - /* Mark vtables in GC chain. GC mark set means delay freeing. */ - SCM chain = newchain; - while (!scm_is_null (chain)) - { - SCM vtable = SCM_STRUCT_VTABLE (chain); - if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain) - SCM_SET_STRUCT_MARK (vtable); - chain = SCM_STRUCT_GC_CHAIN (chain); - } - /* Free unmarked structs. */ - chain = newchain; - newchain = SCM_EOL; - while (!scm_is_null (chain)) - { - SCM obj = chain; - chain = SCM_STRUCT_GC_CHAIN (chain); - if (SCM_STRUCT_MARK_P (obj)) - { - SCM_CLEAR_STRUCT_MARK (obj); - SCM_SET_STRUCT_GC_CHAIN (obj, newchain); - newchain = obj; - } - else - { - scm_t_bits * vtable_data = SCM_STRUCT_VTABLE_DATA (obj); - scm_t_bits * data = SCM_STRUCT_DATA (obj); - scm_t_struct_free free_struct_data - = ((scm_t_struct_free) vtable_data[scm_struct_i_free]); - SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); - free_struct_data (vtable_data, data); - } - } - } - while (!scm_is_null (newchain)); - return 0; +#if 0 + /* A sanity check. However, this check can fail if the free function + changed between the `make-struct' time and now. */ + if (free_struct_data != (scm_t_struct_free)unused_data) + abort (); +#endif + + if (free_struct_data) + free_struct_data (vtable_data, data); } + + + SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, (SCM vtable, SCM tail_array_size, SCM init), "Create a new structure.\n\n" @@ -421,13 +379,15 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, SCM layout; size_t basic_size; size_t tail_elts; - scm_t_bits * data; + scm_t_bits *data, *c_vtable; SCM handle; SCM_VALIDATE_VTABLE (1, vtable); SCM_VALIDATE_REST_ARGUMENT (init); - layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]); + c_vtable = SCM_STRUCT_DATA (vtable); + + layout = SCM_PACK (c_vtable [scm_vtable_index_layout]); basic_size = scm_i_symbol_length (layout) / 2; tail_elts = scm_to_size_t (tail_array_size); @@ -451,7 +411,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, } SCM_CRITICAL_SECTION_START; - if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + if (c_vtable[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) { data = scm_alloc_struct (basic_size + tail_elts, scm_struct_entity_n_extra_words, @@ -463,9 +423,25 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, data = scm_alloc_struct (basic_size + tail_elts, scm_struct_n_extra_words, "struct"); - handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable)) + handle = scm_double_cell ((((scm_t_bits) c_vtable) + scm_tc3_struct), (scm_t_bits) data, 0, 0); + + if (c_vtable[scm_struct_i_free]) + { + /* Register a finalizer for the newly created instance. */ + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalizer_data; + scm_t_struct_free free_struct = + (scm_t_struct_free)c_vtable[scm_struct_i_free]; + + GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (handle), + struct_finalizer_trampoline, + free_struct, + &prev_finalizer, + &prev_finalizer_data); + } + SCM_CRITICAL_SECTION_END; /* In guile 1.8.1 and earlier, the SCM_CRITICAL_SECTION_END above covered @@ -895,11 +871,7 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) void scm_struct_prehistory () { - scm_i_structs_to_free = SCM_EOL; - scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0); - /* With lazy sweep GC, the point at which the entire heap is swept - is just before the mark phase. */ - scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0); + /* Empty. */ } void diff --git a/libguile/struct.h b/libguile/struct.h index 10c0d65c3..cccf429ec 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -80,24 +80,10 @@ SCM_API SCM scm_struct_table; #define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X) #define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y) -/* For clearing structs. We can't use the regular GC mark bits, as - meddling with them at random times would mess up the invariants of - the garbage collector. - */ -#define SCM_STRUCT_MARK_P(X) SCM_CELL_WORD_2 (X) -#define SCM_SET_STRUCT_MARK(X) SCM_SET_CELL_WORD_2 (X, 0x1) -#define SCM_CLEAR_STRUCT_MARK(X) SCM_SET_CELL_WORD_2 (X, 0x0) - -SCM_INTERNAL SCM scm_i_structs_to_free; - SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra, const char *what); -SCM_API void scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data); -SCM_API void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data); -SCM_API void scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data); -SCM_API void scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data); SCM_API SCM scm_make_struct_layout (SCM fields); SCM_API SCM scm_struct_p (SCM x); SCM_API SCM scm_struct_vtable_p (SCM x); diff --git a/libguile/symbols.c b/libguile/symbols.c index d786dd94c..ff75bef7d 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -92,14 +92,40 @@ lookup_interned_symbol (const char *name, size_t len, unsigned long raw_hash) { /* Try to find the symbol in the symbols table */ - SCM l; + SCM result = SCM_BOOL_F; + SCM bucket, elt, previous_elt; unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); - for (l = SCM_HASHTABLE_BUCKET (symbols, hash); - !scm_is_null (l); - l = SCM_CDR (l)) + bucket = SCM_HASHTABLE_BUCKET (symbols, hash); + for (elt = bucket, previous_elt = SCM_BOOL_F; + !scm_is_null (elt); + previous_elt = elt, elt = SCM_CDR (elt)) { - SCM sym = SCM_CAAR (l); + SCM pair, sym; + + pair = SCM_CAR (elt); + if (!scm_is_pair (pair)) + abort (); + + if (SCM_WEAK_PAIR_CAR_DELETED_P (pair)) + { + /* PAIR is a weak pair whose key got nullified: remove it from + BUCKET. */ + /* FIXME: Since this is done lazily, i.e., only when a new symbol + is to be inserted in a bucket containing deleted symbols, the + number of items in the hash table may remain erroneous for some + time, thus precluding proper rehashing. */ + if (previous_elt != SCM_BOOL_F) + SCM_SETCDR (previous_elt, SCM_CDR (elt)); + else + bucket = SCM_CDR (elt); + + SCM_HASHTABLE_DECREMENT (symbols); + continue; + } + + sym = SCM_CAR (pair); + if (scm_i_symbol_hash (sym) == raw_hash && scm_i_symbol_length (sym) == len) { @@ -113,13 +139,19 @@ lookup_interned_symbol (const char *name, size_t len, goto next_symbol; } - return sym; + /* We found it. */ + result = sym; + break; } next_symbol: ; } - return SCM_BOOL_F; + if (SCM_HASHTABLE_N_ITEMS (symbols) < SCM_HASHTABLE_LOWER (symbols)) + /* We removed many symbols in this pass so trigger a rehashing. */ + scm_i_rehash (symbols, scm_i_hash_symbol, 0, "lookup_interned_symbol"); + + return result; } static SCM @@ -139,7 +171,7 @@ scm_i_c_mem2symbol (const char *name, size_t len) scm_cons (SCM_BOOL_F, SCM_EOL)); SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); - SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED); SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); SCM_HASHTABLE_INCREMENT (symbols); if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) @@ -168,7 +200,7 @@ scm_i_mem2symbol (SCM str) scm_cons (SCM_BOOL_F, SCM_EOL)); SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); - SCM cell = scm_cons (symbol, SCM_UNDEFINED); + SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED); SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); SCM_HASHTABLE_INCREMENT (symbols); if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) @@ -438,7 +470,6 @@ void scm_symbols_prehistory () { symbols = scm_make_weak_key_hash_table (scm_from_int (2139)); - scm_permanent_object (symbols); } diff --git a/libguile/threads.c b/libguile/threads.c index 8699fd021..1ccfdca97 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -18,6 +18,7 @@ +#include "libguile/boehm-gc.h" #include "libguile/_scm.h" #if HAVE_UNISTD_H @@ -144,19 +145,6 @@ dequeue (SCM q) /*** Thread smob routines */ -static SCM -thread_mark (SCM obj) -{ - scm_i_thread *t = SCM_I_THREAD_DATA (obj); - scm_gc_mark (t->result); - scm_gc_mark (t->cleanup_handler); - scm_gc_mark (t->join_queue); - scm_gc_mark (t->mutexes); - scm_gc_mark (t->dynwinds); - scm_gc_mark (t->active_asyncs); - scm_gc_mark (t->continuation_root); - return t->dynamic_state; -} static int thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -430,7 +418,7 @@ static SCM scm_i_default_dynamic_state; static void guilify_self_1 (SCM_STACKITEM *base) { - scm_i_thread *t = malloc (sizeof (scm_i_thread)); + scm_i_thread *t = scm_gc_malloc (sizeof (scm_i_thread), "thread"); t->pthread = scm_i_pthread_self (); t->handle = SCM_BOOL_F; @@ -473,6 +461,8 @@ guilify_self_1 (SCM_STACKITEM *base) scm_i_pthread_mutex_init (&t->admin_mutex, NULL); t->clear_freelists_p = 0; t->gc_running_p = 0; + t->current_mark_stack_ptr = NULL; + t->current_mark_stack_limit = NULL; t->canceled = 0; t->exited = 0; @@ -500,7 +490,7 @@ guilify_self_2 (SCM parent) scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM_NEWSMOB (t->handle, scm_tc16_thread, t); - scm_gc_register_collectable_memory (t, sizeof (scm_i_thread), "thread"); + t->continuation_root = scm_cons (t->handle, SCM_EOL); t->continuation_base = t->base; @@ -594,6 +584,17 @@ on_thread_exit (void *v) /* Unblocking the joining threads needs to happen in guile mode since the queue is a SCM data structure. */ + + /* Note: `scm_with_guile ()' invokes `GC_local_malloc ()', which accesses + thread-local storage (TLS). If said storage is accessed using + `pthread_getspecific ()', then it may be inaccessible at this point, + having been destroyed earlier, since the invocation order of destructors + associated with pthread keys is unspecified: + + http://www.opengroup.org/onlinepubs/009695399/functions/pthread_key_create.html + + Thus, `libgc' *must* be compiled with `USE_COMPILER_TLS' for this code + to work. */ scm_with_guile (do_thread_exit, v); /* Removing ourself from the list of all threads needs to happen in @@ -717,7 +718,7 @@ get_thread_stack_base () #ifndef PTHREAD_ATTR_GETSTACK_WORKS if ((void *)&attr < start || (void *)&attr >= end) - return scm_get_stack_base (); + return (SCM_STACKITEM *) GC_stackbottom; else #endif { @@ -749,7 +750,7 @@ get_thread_stack_base () static SCM_STACKITEM * get_thread_stack_base () { - return scm_get_stack_base (); + return (SCM_STACKITEM *) GC_stackbottom; } #endif /* pthread methods of get_thread_stack_base */ @@ -761,7 +762,7 @@ get_thread_stack_base () static SCM_STACKITEM * get_thread_stack_base () { - return scm_get_stack_base (); + return (SCM_STACKITEM *) GC_stackbottom; } #endif /* !SCM_USE_PTHREAD_THREADS */ @@ -1132,13 +1133,6 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, } #undef FUNC_NAME -static SCM -fat_mutex_mark (SCM mx) -{ - fat_mutex *m = SCM_MUTEX_DATA (mx); - scm_gc_mark (m->owner); - return m->waiting; -} static size_t fat_mutex_free (SCM mx) @@ -1556,13 +1550,6 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, } #undef FUNC_NAME -static SCM -fat_cond_mark (SCM cv) -{ - fat_cond *c = SCM_CONDVAR_DATA (cv); - return c->waiting; -} - static size_t fat_cond_free (SCM mx) { @@ -1695,30 +1682,7 @@ SCM_DEFINE (scm_condition_variable_p, "condition-variable?", 1, 0, 0, # define SCM_MARK_BACKING_STORE() #endif -void -scm_threads_mark_stacks (void) -{ - scm_i_thread *t; - for (t = all_threads; t; t = t->next_thread) - { - /* Check that thread has indeed been suspended. - */ - assert (t->top); - scm_gc_mark (t->handle); - -#if SCM_STACK_GROWS_UP - scm_mark_locations (t->base, t->top - t->base); -#else - scm_mark_locations (t->top, t->base - t->top); -#endif - scm_mark_locations ((SCM_STACKITEM *) &t->regs, - ((size_t) sizeof(t->regs) - / sizeof (SCM_STACKITEM))); - } - - SCM_MARK_BACKING_STORE (); -} /*** Select */ @@ -2017,18 +1981,15 @@ void scm_init_threads () { scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread)); - scm_set_smob_mark (scm_tc16_thread, thread_mark); scm_set_smob_print (scm_tc16_thread, thread_print); - scm_set_smob_free (scm_tc16_thread, thread_free); + scm_set_smob_free (scm_tc16_thread, thread_free); /* XXX: Could be removed */ scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex)); - scm_set_smob_mark (scm_tc16_mutex, fat_mutex_mark); scm_set_smob_print (scm_tc16_mutex, fat_mutex_print); scm_set_smob_free (scm_tc16_mutex, fat_mutex_free); scm_tc16_condvar = scm_make_smob_type ("condition-variable", sizeof (fat_cond)); - scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark); scm_set_smob_print (scm_tc16_condvar, fat_cond_print); scm_set_smob_free (scm_tc16_condvar, fat_cond_free); diff --git a/libguile/threads.h b/libguile/threads.h index dea1a8e5d..00fca92e4 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -79,6 +79,11 @@ typedef struct scm_i_thread { int gc_running_p; /* non-zero while this thread does GC or a sweep. */ + /* Information about the Boehm-GC mark stack during the mark phase. This + is used by `scm_gc_mark ()'. */ + void *current_mark_stack_ptr; + void *current_mark_stack_limit; + /* Other thread local things. */ SCM dynamic_state; @@ -148,9 +153,9 @@ SCM_INTERNAL void scm_i_thread_wake_up (void); SCM_INTERNAL void scm_i_thread_invalidate_freelists (void); void scm_i_thread_sleep_for_gc (void); -SCM_INTERNAL void scm_threads_prehistory (SCM_STACKITEM *); -SCM_INTERNAL void scm_threads_init_first_thread (void); -SCM_INTERNAL void scm_threads_mark_stacks (void); +void scm_threads_prehistory (SCM_STACKITEM *); +void scm_threads_init_first_thread (void); + SCM_INTERNAL void scm_init_threads (void); SCM_INTERNAL void scm_init_thread_procs (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); diff --git a/libguile/unif.c b/libguile/unif.c index d61532bb0..d3bf82314 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1469,14 +1469,6 @@ static scm_t_bits scm_tc16_bitvector; #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj)) #define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj)) -static size_t -bitvector_free (SCM vec) -{ - scm_gc_free (BITVECTOR_BITS (vec), - sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32), - "bitvector"); - return 0; -} static int bitvector_print (SCM vec, SCM port, scm_print_state *pstate) @@ -2842,21 +2834,6 @@ SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, #endif -static SCM -array_mark (SCM ptr) -{ - return SCM_I_ARRAY_V (ptr); -} - -static size_t -array_free (SCM ptr) -{ - scm_gc_free (SCM_I_ARRAY_MEM (ptr), - (sizeof (scm_i_t_array) - + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), - "array"); - return 0; -} #if SCM_ENABLE_DEPRECATED @@ -2926,21 +2903,16 @@ void scm_init_unif () { scm_i_tc16_array = scm_make_smob_type ("array", 0); - scm_set_smob_mark (scm_i_tc16_array, array_mark); - scm_set_smob_free (scm_i_tc16_array, array_free); scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); - scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark); - scm_set_smob_free (scm_i_tc16_enclosed_array, array_free); scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array); scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p); scm_add_feature ("array"); scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); - scm_set_smob_free (scm_tc16_bitvector, bitvector_free); scm_set_smob_print (scm_tc16_bitvector, bitvector_print); scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); diff --git a/libguile/vectors.c b/libguile/vectors.c index fef48cc3e..c3107ecf1 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -34,6 +34,9 @@ #include "libguile/dynwind.h" #include "libguile/deprecation.h" +#include "libguile/boehm-gc.h" + + #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) @@ -61,6 +64,11 @@ const SCM * scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { + if (SCM_I_WVECTP (vec)) + /* FIXME: We should check each (weak) element of the vector for NULL and + convert it to SCM_BOOL_F. */ + abort (); + scm_generalized_vector_get_handle (vec, h); if (lenp) { @@ -75,6 +83,11 @@ SCM * scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { + if (SCM_I_WVECTP (vec)) + /* FIXME: We should check each (weak) element of the vector for NULL and + convert it to SCM_BOOL_F. */ + abort (); + scm_generalized_vector_get_handle (vec, h); if (lenp) { @@ -192,9 +205,17 @@ scm_c_vector_ref (SCM v, size_t k) { if (SCM_I_IS_VECTOR (v)) { + register SCM elt; + if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - return (SCM_I_VECTOR_ELTS(v))[k]; + scm_out_of_range (NULL, scm_from_size_t (k)); + elt = (SCM_I_VECTOR_ELTS(v))[k]; + + if ((elt == SCM_PACK (NULL)) && SCM_I_WVECTP (v)) + /* ELT was a weak pointer and got nullified by the GC. */ + return SCM_BOOL_F; + + return elt; } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -202,10 +223,18 @@ scm_c_vector_ref (SCM v, size_t k) SCM vv = SCM_I_ARRAY_V (v); if (SCM_I_IS_VECTOR (vv)) { + register SCM elt; + if (k >= dim->ubnd - dim->lbnd + 1) scm_out_of_range (NULL, scm_from_size_t (k)); k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - return (SCM_I_VECTOR_ELTS (vv))[k]; + elt = (SCM_I_VECTOR_ELTS (vv))[k]; + + if ((elt == SCM_PACK (NULL)) && (SCM_I_WVECTP (vv))) + /* ELT was a weak pointer and got nullified by the GC. */ + return SCM_BOOL_F; + + return elt; } scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); } @@ -243,6 +272,12 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); (SCM_I_VECTOR_WELTS(v))[k] = obj; + if (SCM_I_WVECTP (v)) + { + /* Make it a weak pointer. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) { @@ -254,6 +289,13 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) scm_out_of_range (NULL, scm_from_size_t (k)); k = SCM_I_ARRAY_BASE (v) + k*dim->inc; (SCM_I_VECTOR_WELTS (vv))[k] = obj; + + if (SCM_I_WVECTP (vv)) + { + /* Make it a weak pointer. */ + GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]); + GC_GENERAL_REGISTER_DISAPPEARING_LINK (link, obj); + } } else scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); @@ -342,43 +384,85 @@ scm_i_vector_free (SCM vec) "vector"); } -/* Allocate memory for a weak vector on behalf of the caller. The allocated - * vector will be of the given weak vector subtype. It will contain size - * elements which are initialized with the 'fill' object, or, if 'fill' is - * undefined, with an unspecified object. - */ -SCM -scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill) + +/* Weak vectors. */ + + +/* Initialize RET as a weak vector of type TYPE of SIZE elements pointed to + by BASE. */ +#define MAKE_WEAK_VECTOR(_ret, _type, _size, _base) \ + (_ret) = scm_double_cell ((_size << 8) | scm_tc7_wvect, \ + (scm_t_bits) (_base), \ + (_type), \ + SCM_UNPACK (SCM_EOL)); + + +/* Allocate memory for the elements of a weak vector on behalf of the + caller. */ +static SCM * +allocate_weak_vector (scm_t_bits type, size_t c_size) { - size_t c_size; SCM *base; - SCM v; + + if (c_size > 0) + /* The base itself should not be scanned for pointers otherwise those + pointers will always be reachable. */ + base = scm_gc_malloc_pointerless (c_size * sizeof (SCM), "weak vector"); + else + base = NULL; + + return base; +} + +/* Return a new weak vector. The allocated vector will be of the given weak + vector subtype. It will contain SIZE elements which are initialized with + the FILL object, or, if FILL is undefined, with an unspecified object. */ +SCM +scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill) +{ + SCM wv, *base; + size_t c_size, j; + + if (SCM_UNBNDP (fill)) + fill = SCM_UNSPECIFIED; c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH); + base = allocate_weak_vector (type, c_size); - if (c_size > 0) + for (j = 0; j != c_size; ++j) + base[j] = fill; + + MAKE_WEAK_VECTOR (wv, type, c_size, base); + + return wv; +} + +/* Return a new weak vector with type TYPE and whose content are taken from + list LST. */ +SCM +scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst) +{ + SCM wv, *base, *elt; + long c_size; + + c_size = scm_ilength (lst); + SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list"); + + base = allocate_weak_vector (type, (size_t)c_size); + for (elt = base; + scm_is_pair (lst); + lst = SCM_CDR (lst), elt++) { - size_t j; - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector"); - for (j = 0; j != c_size; ++j) - base[j] = fill; + *elt = SCM_CAR (lst); } - else - base = NULL; - v = scm_double_cell ((c_size << 8) | scm_tc7_wvect, - (scm_t_bits) base, - type, - SCM_UNPACK (SCM_EOL)); - scm_remember_upto_here_1 (fill); + MAKE_WEAK_VECTOR (wv, type, (size_t)c_size, base); - return v; + return wv; } + + SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, (SCM v), "Return a newly allocated list composed of the elements of @var{v}.\n" diff --git a/libguile/vectors.h b/libguile/vectors.h index 28a576c5c..7a508c77b 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -99,7 +99,8 @@ SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y); #define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x)) #define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o))) -SCM_INTERNAL SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill); +SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill); +SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst); SCM_INTERNAL void scm_init_vectors (void); diff --git a/libguile/weaks.c b/libguile/weaks.c index 2e1131570..6d69f9718 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -28,6 +28,92 @@ #include "libguile/validate.h" #include "libguile/weaks.h" +#include "libguile/boehm-gc.h" +#include <gc/gc_typed.h> + + + +/* Weak pairs for use in weak alist vectors and weak hash tables. + + We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak + pairs, the weak component(s) are not scanned for pointers and are + registered as disapperaring links; therefore, the weak component may be + set to NULL by the garbage collector when no other reference to that word + exist. Thus, users should only access weak pairs via the + `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in + `hashtab.c'. */ + +/* Type descriptors for weak-c[ad]r pairs. */ +static GC_descr wcar_pair_descr, wcdr_pair_descr; + + +SCM +scm_weak_car_pair (SCM car, SCM cdr) +{ + scm_t_cell *cell; + + cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell), + wcar_pair_descr); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (car)) + { + /* Weak car cells make sense iff the car is non-immediate. */ + GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0, + (GC_PTR)SCM_UNPACK (car)); + } + + return (SCM_PACK (cell)); +} + +SCM +scm_weak_cdr_pair (SCM car, SCM cdr) +{ + scm_t_cell *cell; + + cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell), + wcdr_pair_descr); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (cdr)) + { + /* Weak cdr cells make sense iff the cdr is non-immediate. */ + GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1, + (GC_PTR)SCM_UNPACK (cdr)); + } + + return (SCM_PACK (cell)); +} + +SCM +scm_doubly_weak_pair (SCM car, SCM cdr) +{ + /* Doubly weak cells shall not be scanned at all for pointers. */ + scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell), + "weak cell"); + + cell->word_0 = car; + cell->word_1 = cdr; + + if (SCM_NIMP (car)) + { + GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0, + (GC_PTR)SCM_UNPACK (car)); + } + if (SCM_NIMP (cdr)) + { + GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1, + (GC_PTR)SCM_UNPACK (cdr)); + } + + return (SCM_PACK (cell)); +} + + /* 1. The current hash table implementation in hashtab.c uses weak alist @@ -52,7 +138,7 @@ SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, "empty list.") #define FUNC_NAME s_scm_make_weak_vector { - return scm_i_allocate_weak_vector (0, size, fill); + return scm_i_make_weak_vector (0, size, fill); } #undef FUNC_NAME @@ -68,26 +154,7 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, "the same way @code{list->vector} would.") #define FUNC_NAME s_scm_weak_vector { - scm_t_array_handle handle; - SCM res, *data; - long i; - - i = scm_ilength (l); - SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); - - res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED); - data = scm_vector_writable_elements (res, &handle, NULL, NULL); - - while (scm_is_pair (l) && i > 0) - { - *data++ = SCM_CAR (l); - l = SCM_CDR (l); - i--; - } - - scm_array_handle_release (&handle); - - return res; + return scm_i_make_weak_vector_from_list (0, l); } #undef FUNC_NAME @@ -103,6 +170,16 @@ SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, #undef FUNC_NAME +/* Weak alist vectors, i.e., vectors of alists. + + The alist vector themselves are _not_ weak. The `car' (or `cdr', or both) + of the pairs within it are weak. See `hashtab.c' for details. */ + + +/* FIXME: We used to have two implementations of weak hash tables: the one in + here and the one in `hashtab.c'. The difference is that weak alist + vectors could be used as vectors while (weak) hash tables can't. We need + to unify that. */ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0, (SCM size), @@ -116,8 +193,7 @@ SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, "would modify regular hash tables. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_key_alist_vector { - return scm_i_allocate_weak_vector - (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_weak_key_hash_table (size); } #undef FUNC_NAME @@ -128,8 +204,7 @@ SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, "(@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_weak_value_alist_vector { - return scm_i_allocate_weak_vector - (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_weak_value_hash_table (size); } #undef FUNC_NAME @@ -140,8 +215,7 @@ SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", "buckets. (@pxref{Hash Tables})") #define FUNC_NAME s_scm_make_doubly_weak_alist_vector { - return scm_i_allocate_weak_vector - (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL); + return scm_make_doubly_weak_hash_table (size); } #undef FUNC_NAME @@ -179,180 +253,9 @@ SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0 } #undef FUNC_NAME -#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) - -static SCM weak_vectors; - -void -scm_i_init_weak_vectors_for_gc () -{ - weak_vectors = SCM_EOL; -} - -void -scm_i_mark_weak_vector (SCM w) -{ - SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors); - weak_vectors = w; -} - -static int -scm_i_mark_weak_vector_non_weaks (SCM w) -{ - int again = 0; - - if (SCM_IS_WHVEC_ANY (w)) - { - SCM *ptr; - long n = SCM_I_WVECT_LENGTH (w); - long j; - int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w); - int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w); - - ptr = SCM_I_WVECT_GC_WVELTS (w); - - for (j = 0; j < n; ++j) - { - SCM alist, slow_alist; - int slow_toggle = 0; - - /* We do not set the mark bits of the alist spine cells here - since we do not want to ever create the situation where a - marked cell references an unmarked cell (except in - scm_gc_mark, where the referenced cells will be marked - immediately). Thus, we can not use mark bits to stop us - from looping indefinitely over a cyclic alist. Instead, - we use the standard tortoise and hare trick to catch - cycles. The fast walker does the work, and stops when it - catches the slow walker to ensure that the whole cycle - has been worked on. - */ - - alist = slow_alist = ptr[j]; - - while (scm_is_pair (alist)) - { - SCM elt = SCM_CAR (alist); - - if (UNMARKED_CELL_P (elt)) - { - if (scm_is_pair (elt)) - { - SCM key = SCM_CAR (elt); - SCM value = SCM_CDR (elt); - - if (!((weak_keys && UNMARKED_CELL_P (key)) - || (weak_values && UNMARKED_CELL_P (value)))) - { - /* The item should be kept. We need to mark it - recursively. - */ - scm_gc_mark (elt); - again = 1; - } - } - else - { - /* A non-pair cell element. This should not - appear in a real alist, but when it does, we - need to keep it. - */ - scm_gc_mark (elt); - again = 1; - } - } - - alist = SCM_CDR (alist); - - if (slow_toggle && scm_is_pair (slow_alist)) - { - slow_alist = SCM_CDR (slow_alist); - slow_toggle = !slow_toggle; - if (scm_is_eq (slow_alist, alist)) - break; - } - } - if (!scm_is_pair (alist)) - scm_gc_mark (alist); - } - } - - return again; -} - -int -scm_i_mark_weak_vectors_non_weaks () -{ - int again = 0; - SCM w = weak_vectors; - while (!scm_is_null (w)) - { - if (scm_i_mark_weak_vector_non_weaks (w)) - again = 1; - w = SCM_I_WVECT_GC_CHAIN (w); - } - return again; -} - -static void -scm_i_remove_weaks (SCM w) -{ - SCM *ptr = SCM_I_WVECT_GC_WVELTS (w); - size_t n = SCM_I_WVECT_LENGTH (w); - size_t i; - - if (!SCM_IS_WHVEC_ANY (w)) - { - for (i = 0; i < n; ++i) - if (UNMARKED_CELL_P (ptr[i])) - ptr[i] = SCM_BOOL_F; - } - else - { - size_t delta = 0; - - for (i = 0; i < n; ++i) - { - SCM alist, *fixup; - - fixup = ptr + i; - alist = *fixup; - while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist)) - { - if (UNMARKED_CELL_P (SCM_CAR (alist))) - { - *fixup = SCM_CDR (alist); - delta++; - } - else - { - SCM_SET_GC_MARK (alist); - fixup = SCM_CDRLOC (alist); - } - alist = *fixup; - } - } -#if 0 - if (delta) - fprintf (stderr, "vector %p, delta %d\n", w, delta); -#endif - SCM_I_SET_WVECT_DELTA (w, delta); - } -} -void -scm_i_remove_weaks_from_weak_vectors () -{ - SCM w = weak_vectors; - while (!scm_is_null (w)) - { - scm_i_remove_weaks (w); - w = SCM_I_WVECT_GC_CHAIN (w); - } -} - SCM scm_init_weaks_builtins () { @@ -361,6 +264,27 @@ scm_init_weaks_builtins () } void +scm_weaks_prehistory () +{ + /* Initialize weak pairs. */ + GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 }; + GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 }; + + /* In a weak-car pair, only the second word must be scanned for + pointers. */ + GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1)); + wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap, + GC_WORD_LEN (scm_t_cell)); + + /* Conversely, in a weak-cdr pair, only the first word must be scanned for + pointers. */ + GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0)); + wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap, + GC_WORD_LEN (scm_t_cell)); + +} + +void scm_init_weaks () { scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0, diff --git a/libguile/weaks.h b/libguile/weaks.h index 34c44a97a..81c17749f 100644 --- a/libguile/weaks.h +++ b/libguile/weaks.h @@ -52,6 +52,34 @@ #define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0) +/* Weak pairs. */ + +SCM_API SCM scm_weak_car_pair (SCM car, SCM cdr); +SCM_API SCM scm_weak_cdr_pair (SCM car, SCM cdr); +SCM_API SCM scm_doubly_weak_pair (SCM car, SCM cdr); + +/* Testing the weak component(s) of a cell for reachability. */ +#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \ + (SCM_CELL_OBJECT ((_cell), (_word)) == SCM_PACK (NULL)) +#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \ + (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0)) +#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \ + (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1)) + +#define SCM_WEAK_PAIR_DELETED_P(_cell) \ + ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \ + || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell))) + +/* Accessing the components of a weak cell. */ +#define SCM_WEAK_PAIR_WORD(_cell, _word) \ + ((SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word))) \ + ? SCM_BOOL_F : SCM_CAR (pair)) +#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0)) +#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1)) + + + +/* Weak vectors and weak hash tables. */ SCM_API SCM scm_make_weak_vector (SCM k, SCM fill); SCM_API SCM scm_weak_vector (SCM l); @@ -63,6 +91,7 @@ SCM_API SCM scm_weak_key_alist_vector_p (SCM x); SCM_API SCM scm_weak_value_alist_vector_p (SCM x); SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x); SCM_INTERNAL SCM scm_init_weaks_builtins (void); +SCM_INTERNAL void scm_weaks_prehistory (void); SCM_INTERNAL void scm_init_weaks (void); SCM_INTERNAL void scm_i_init_weak_vectors_for_gc (void); diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 4a9380849..e6ea258c5 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -30,7 +30,6 @@ SCM_TESTS = tests/alist.test \ tests/common-list.test \ tests/continuations.test \ tests/elisp.test \ - tests/environments.test \ tests/eval.test \ tests/exceptions.test \ tests/filesys.test \ diff --git a/test-suite/tests/environments.test b/test-suite/tests/environments.nottest index 646efc56a..46883849a 100644 --- a/test-suite/tests/environments.test +++ b/test-suite/tests/environments.nottest @@ -15,7 +15,8 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(use-modules (ice-9 documentation)) +(use-modules (ice-9 documentation) + (test-suite lib)) ;;; environments are currently commented out of libguile, so these ;;; tests must be commented out also. - NJ 2006-11-02. diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index badf2b79c..0fdfaaf6d 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -1,5 +1,5 @@ ;;;; gc.test --- test guile's garbage collection -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -59,12 +59,13 @@ (with-test-prefix "gc" (pass-if "Unused modules are removed" - (let* - ((dummy (gc)) - (last-count (cdr (assoc - "eval-closure" (gc-live-object-stats))))) + ;; FIXME: This test fails because of the circular reference + ;; created by `make-module' between the module itself and its + ;; standard eval closure. + (let* ((guard (make-guardian)) + (total 1000)) - (for-each (lambda (x) (make-module)) (iota 1000)) + (for-each (lambda (x) (guard (make-module))) (iota total)) ;; XXX: This hack aims to clean up the stack to make sure we ;; don't leave a reference to one of the modules we created. It @@ -76,5 +77,8 @@ (gc) (gc) ;; twice: have to kill the weak vectors. - (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats))))) - )) + (= (length (filter (lambda (x) + (eq? x #t)) + (map (lambda (x) (and (guard) #t)) + (iota total)))) + total)))) diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test index 15f67e609..e6a4203a2 100644 --- a/test-suite/tests/guardians.test +++ b/test-suite/tests/guardians.test @@ -41,11 +41,18 @@ (gc) ;;; Who guards the guardian? + +;;; Note: We use strings rather than symbols because symbols are usually +;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them +;;; inappropriate for the tests below. Furthermore, we use `string-copy' in +;;; order to make sure that no string is kept around in the interpreter +;;; unwillingly (e.g., in the source-property weak hash table). + (gc) (define g2 (make-guardian)) -(g2 (list 'g2-garbage)) +(g2 (list (string-copy "g2-garbage"))) (define g3 (make-guardian)) -(g3 (list 'g3-garbage)) +(g3 (list (string-copy "g3-garbage"))) (g3 g2) (pass-if "g2-garbage not collected yet" (equal? (g2) #f)) (pass-if "g3-garbage not collected yet" (equal? (g3) #f)) @@ -59,15 +66,18 @@ (if saved (begin (cond - ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t)) + ((equal? saved (list (string-copy "g3-garbage"))) + (set! seen-g3-garbage #t)) ((procedure? saved) (set! seen-g2 saved)) - (else (pk saved) (set! seen-something-else #t))) + (else (pk 'junk saved) (set! seen-something-else #t))) (loop))))) (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved))) (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved))) (pass-if "nothing else saved" (not seen-something-else)) (pass-if "g2-garbage saved" (or (and (procedure? seen-g2) - (equal? (seen-g2) '(g2-garbage))) + (equal? (seen-g2) + (list (string-copy + "g2-garbage")))) (throw 'unresolved)))) (with-test-prefix "standard guardian functionality" |