X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/406c7d902207af0e25afc6d543e94067bc92bf2b..1c44468d771d664d459e22d18884d36dda6908c1:/libguile/weaks.c diff --git a/libguile/weaks.c b/libguile/weaks.c dissimilarity index 84% index 71905ac05..abe929254 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -1,338 +1,303 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, Free Software Foundation gives permission - * for additional uses of the text contained in its release of this library. - * - * The exception is that, if you link this library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking this library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by - * Free Software Foundation as part of this library. If you copy - * code from other releases distributed under the terms of the GPL into a copy of - * this library, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from such code. - * - * If you write modifications of your own for this library, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ - - -#include -#include "libguile/_scm.h" -#include "libguile/vectors.h" - -#include "libguile/validate.h" -#include "libguile/weaks.h" - - - -/* {Weak Vectors} - */ - - -SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, - (SCM k, SCM fill), - "Return a weak vector with @var{size} elements. If the optional\n" - "argument @var{fill} is given, all entries in the vector will be set to\n" - "@var{fill}. The default value for @var{fill} is the empty list.") -#define FUNC_NAME s_scm_make_weak_vector -{ - SCM v; - v = scm_make_vector (scm_sum (k, SCM_MAKINUM (2)), fill); - SCM_DEFER_INTS; - SCM_SETLENGTH(v, SCM_INUM (k), scm_tc7_wvect); - SCM_SETVELTS(v, SCM_VELTS(v) + 2); - SCM_VELTS(v)[-2] = SCM_EOL; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 0; - SCM_ALLOW_INTS; - return v; -} -#undef FUNC_NAME - - -SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); - -SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, - (SCM l), - "@deffnx primitive list->weak-vector l\n" - "Construct a weak vector from a list: @code{weak-vector} uses the list of\n" - "its arguments while @code{list->weak-vector} uses its only argument\n" - "@var{l} (a list) to construct a weak vector the same way\n" - "@code{vector->list} would.") -#define FUNC_NAME s_scm_weak_vector -{ - SCM res; - register SCM *data; - long i; - - i = scm_ilength (l); - SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); - res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); - data = SCM_VELTS (res); - for (; - i && SCM_CONSP (l); - --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, - (SCM x), - "Return @var{#t} if @var{obj} is a weak vector. Note that all weak\n" - "hashes are also weak vectors.") -#define FUNC_NAME s_scm_weak_vector_p -{ - return SCM_BOOL(SCM_WVECTP (x) && !SCM_IS_WHVEC (x)); -} -#undef FUNC_NAME - - - - - - - -SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, - (SCM k), - "@deffnx primitive make-weak-value-hash-table size\n" - "@deffnx primitive make-doubly-weak-hash-table size\n" - "Return a weak hash table with @var{size} buckets. As with any hash\n" - "table, choosing a good size for the table requires some caution.\n\n" - "You can modify weak hash tables in exactly the same way you would modify\n" - "regular hash tables. (@pxref{Hash Tables})") -#define FUNC_NAME s_scm_make_weak_key_hash_table -{ - SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 1; - SCM_ALLOW_INTS; - return v; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, - (SCM k), - "") -#define FUNC_NAME s_scm_make_weak_value_hash_table -{ - SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 2; - SCM_ALLOW_INTS; - return v; -} -#undef FUNC_NAME - - - -SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, - (SCM k), - "") -#define FUNC_NAME s_scm_make_doubly_weak_hash_table -{ - SCM v; - SCM_VALIDATE_INUM (1,k); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_DEFER_INTS; - SCM_UNPACK (SCM_VELTS (v)[-1]) = 3; - SCM_ALLOW_INTS; - return v; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, - (SCM x), - "@deffnx primitive weak-value-hash-table? obj\n" - "@deffnx primitive doubly-weak-hash-table? obj\n" - "Return @var{#t} if @var{obj} is the specified weak hash table. Note\n" - "that a doubly weak hash table is neither a weak key nor a weak value\n" - "hash table.") -#define FUNC_NAME s_scm_weak_key_hash_table_p -{ - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC(x)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, - (SCM x), - "") -#define FUNC_NAME s_scm_weak_value_hash_table_p -{ - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, - (SCM x), - "") -#define FUNC_NAME s_scm_doubly_weak_hash_table_p -{ - return SCM_BOOL(SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)); -} -#undef FUNC_NAME - -static void * -scm_weak_vector_gc_init (void *dummy1, void *dummy2, void *dummy3) -{ - scm_weak_vectors = SCM_EOL; - - return 0; -} - -static void * -scm_mark_weak_vector_spines (void *dummy1, void *dummy2, void *dummy3) -{ - SCM w; - - for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w)) - { - if (SCM_IS_WHVEC_ANY (w)) - { - SCM *ptr; - SCM obj; - int j; - int n; - - obj = w; - ptr = SCM_VELTS (w); - n = SCM_LENGTH (w); - for (j = 0; j < n; ++j) - { - SCM alist; - - alist = ptr[j]; - while ( SCM_CONSP (alist) - && !SCM_GCMARKP (alist) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM_SETGCMARK (alist); - SCM_SETGCMARK (SCM_CAR (alist)); - alist = SCM_GCCDR (alist); - } - } - } - } - - return 0; -} - -static void * -scm_scan_weak_vectors (void *dummy1, void *dummy2, void *dummy3) -{ - SCM *ptr, w; - for (w = scm_weak_vectors; !SCM_NULLP (w); w = SCM_WVECT_GC_CHAIN (w)) - { - if (!SCM_IS_WHVEC_ANY (w)) - { - register long j, n; - - ptr = SCM_VELTS (w); - n = SCM_LENGTH (w); - for (j = 0; j < n; ++j) - if (SCM_FREE_CELL_P (ptr[j])) - ptr[j] = SCM_BOOL_F; - } - else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ - { - SCM obj = w; - register long n = SCM_LENGTH (w); - register long j; - - ptr = SCM_VELTS (w); - - for (j = 0; j < n; ++j) - { - SCM * fixup; - SCM alist; - int weak_keys; - int weak_values; - - weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); - weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); - - fixup = ptr + j; - alist = *fixup; - - while ( SCM_CONSP (alist) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM key; - SCM value; - - key = SCM_CAAR (alist); - value = SCM_CDAR (alist); - if ( (weak_keys && SCM_FREE_CELL_P (key)) - || (weak_values && SCM_FREE_CELL_P (value))) - { - *fixup = SCM_CDR (alist); - } - else - fixup = SCM_CDRLOC (alist); - alist = SCM_CDR (alist); - } - } - } - } - - return 0; -} - - - - - -void -scm_weaks_prehistory () -{ - scm_c_hook_add (&scm_before_mark_c_hook, scm_weak_vector_gc_init, 0, 0); - scm_c_hook_add (&scm_before_sweep_c_hook, scm_mark_weak_vector_spines, 0, 0); - scm_c_hook_add (&scm_after_sweep_c_hook, scm_scan_weak_vectors, 0, 0); -} - -void -scm_init_weaks () -{ -#include "libguile/weaks.x" -} - - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ +/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 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 3 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 + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/vectors.h" +#include "libguile/lang.h" +#include "libguile/hashtab.h" + +#include "libguile/validate.h" +#include "libguile/weaks.h" + +#include "libguile/bdw-gc.h" +#include + + + +/* 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 + * vectors (formerly called weak hash tables) internally. + * + * 2. All hash table operations still work on alist vectors. + * + * 3. The weak vector and alist vector Scheme API is accessed through + * the module (ice-9 weak-vector). + */ + + +/* {Weak Vectors} + */ + + +SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, + (SCM size, SCM fill), + "Return a weak vector with @var{size} elements. If the optional\n" + "argument @var{fill} is given, all entries in the vector will be\n" + "set to @var{fill}. The default value for @var{fill} is the\n" + "empty list.") +#define FUNC_NAME s_scm_make_weak_vector +{ + return scm_i_make_weak_vector (0, size, fill); +} +#undef FUNC_NAME + + +SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); + +SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, + (SCM l), + "@deffnx {Scheme Procedure} list->weak-vector l\n" + "Construct a weak vector from a list: @code{weak-vector} uses\n" + "the list of its arguments while @code{list->weak-vector} uses\n" + "its only argument @var{l} (a list) to construct a weak vector\n" + "the same way @code{list->vector} would.") +#define FUNC_NAME s_scm_weak_vector +{ + return scm_i_make_weak_vector_from_list (0, l); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a weak vector. Note that all\n" + "weak hashes are also weak vectors.") +#define FUNC_NAME s_scm_weak_vector_p +{ + return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj)); +} +#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), + "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n" + "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n" + "Return a weak hash table with @var{size} buckets. As with any\n" + "hash table, choosing a good size for the table requires some\n" + "caution.\n" + "\n" + "You can modify weak hash tables in exactly the same way you\n" + "would modify regular hash tables. (@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_weak_key_alist_vector +{ + return scm_make_weak_key_hash_table (size); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0, + (SCM size), + "Return a hash table with weak values with @var{size} buckets.\n" + "(@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_weak_value_alist_vector +{ + return scm_make_weak_value_hash_table (size); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0, + (SCM size), + "Return a hash table with weak keys and values with @var{size}\n" + "buckets. (@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_doubly_weak_alist_vector +{ + return scm_make_doubly_weak_hash_table (size); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0, + (SCM obj), + "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n" + "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n" + "Return @code{#t} if @var{obj} is the specified weak hash\n" + "table. Note that a doubly weak hash table is neither a weak key\n" + "nor a weak value hash table.") +#define FUNC_NAME s_scm_weak_key_alist_vector_p +{ + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a weak value hash table.") +#define FUNC_NAME s_scm_weak_value_alist_vector_p +{ + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a doubly weak hash table.") +#define FUNC_NAME s_scm_doubly_weak_alist_vector_p +{ + return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj)); +} +#undef FUNC_NAME + + + + +SCM +scm_init_weaks_builtins () +{ +#include "libguile/weaks.x" + return SCM_UNSPECIFIED; +} + +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, + scm_init_weaks_builtins); +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/