From: Andy Wingo Date: Fri, 6 Jul 2012 14:52:54 +0000 (+0200) Subject: Merge remote-tracking branch 'origin/stable-2.0' X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/2aed2667fce5ccb115667a36ffd368c4c3b6e9f4 Merge remote-tracking branch 'origin/stable-2.0' Conflicts: libguile/expand.c libguile/hashtab.c libguile/ports.c libguile/vectors.c libguile/weaks.c module/language/ecmascript/compile-tree-il.scm module/language/tree-il/effects.scm module/language/tree-il/fix-letrec.scm module/language/tree-il/peval.scm test-suite/tests/peval.test --- 2aed2667fce5ccb115667a36ffd368c4c3b6e9f4 diff --cc configure.ac index 60d0164eb,0eb937c13..506268d65 --- a/configure.ac +++ b/configure.ac @@@ -29,7 -29,7 +29,7 @@@ Floor, Boston, MA 02110-1301, USA AC_PREREQ(2.61) AC_INIT([GNU Guile], - m4_esyscmd([build-aux/git-version-gen .tarball-version]), - m4_esyscmd([build-aux/git-version-gen --match v2.0.\* .tarball-version]), ++ m4_esyscmd([build-aux/git-version-gen --match v2.\[12\].\* .tarball-version]), [bug-guile@gnu.org]) AC_CONFIG_AUX_DIR([build-aux]) AC_CONFIG_MACRO_DIR([m4]) diff --cc libguile/expand.c index 3f23d4f8f,cae552086..cb32e371c --- a/libguile/expand.c +++ b/libguile/expand.c @@@ -1,4 -1,4 +1,4 @@@ - /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011 -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2012 ++/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or diff --cc libguile/foreign.c index 072b4b62b,320e20d8b..47077f7f8 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@@ -96,10 -99,10 +96,10 @@@ register_weak_reference (SCM from, SCM } static void - pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data) + pointer_finalizer_trampoline (void *ptr, void *data) { scm_t_pointer_finalizer finalizer = data; - finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr))); + finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr))); } SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0, diff --cc libguile/guardians.c index a3d03230a,022f54e63..8a0d2961c --- a/libguile/guardians.c +++ b/libguile/guardians.c @@@ -166,10 -165,10 +167,10 @@@ finalize_guarded (void *ptr, void *fina /* 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; + void *finalizer_data, *prev_finalizer_data; - finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer)); - finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer)); + finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR (proxied_finalizer)); + finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer)); if (finalizer == NULL) abort (); diff --cc libguile/ports.c index f91b80ee3,2f8c79217..11142ba65 --- a/libguile/ports.c +++ b/libguile/ports.c @@@ -553,9 -556,10 +553,9 @@@ do_free (void *body_data /* Finalize the object (a port) pointed to by PTR. */ static void - finalize_port (GC_PTR ptr, GC_PTR data) + finalize_port (void *ptr, void *data) { - long port_type; - SCM port = PTR2SCM (ptr); + SCM port = SCM_PACK_POINTER (ptr); if (!SCM_PORTP (port)) abort (); @@@ -826,230 -933,210 +826,230 @@@ scm_i_set_default_port_encoding (const } } -SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0, - (SCM proc), - "Apply @var{proc} to each port in the Guile port table\n" - "in turn. The return value is unspecified. More specifically,\n" - "@var{proc} is applied exactly once to every port that exists\n" - "in the system at the time @code{port-for-each} is invoked.\n" - "Changes to the port table while @code{port-for-each} is running\n" - "have no effect as far as @code{port-for-each} is concerned.") -#define FUNC_NAME s_scm_port_for_each +/* Return the name of the default encoding for newly created ports; a + return value of NULL means "ISO-8859-1". */ +const char * +scm_i_default_port_encoding (void) { - SCM ports; - - SCM_VALIDATE_PROC (1, proc); + if (!scm_port_encoding_init) + return NULL; + else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var))) + return NULL; + else + { + SCM encoding; - /* Copy out the port table as a list so that we get strong references - to all the values. */ - scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); - ports = scm_internal_hash_fold (collect_keys, NULL, - SCM_EOL, scm_i_port_weak_hash); - scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); + if (!scm_is_string (encoding)) + return NULL; + else + return scm_i_string_chars (encoding); + } +} - for (; scm_is_pair (ports); ports = scm_cdr (ports)) - if (SCM_PORTP (SCM_CAR (ports))) - scm_call_1 (proc, SCM_CAR (ports)); +/* A fluid specifying the default conversion handler for newly created + ports. Its value should be one of the symbols below. */ +SCM_VARIABLE (default_conversion_strategy_var, + "%default-port-conversion-strategy"); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME +/* Whether the above fluid is initialized. */ +static int scm_conversion_strategy_init = 0; +/* The possible conversion strategies. */ +SCM_SYMBOL (sym_error, "error"); +SCM_SYMBOL (sym_substitute, "substitute"); +SCM_SYMBOL (sym_escape, "escape"); - -/* Utter miscellany. Gosh, we should clean this up some time. */ +/* Return the default failed encoding conversion policy for new created + ports. */ +scm_t_string_failed_conversion_handler +scm_i_default_port_conversion_handler (void) +{ + scm_t_string_failed_conversion_handler handler; -SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is an input port, otherwise return\n" - "@code{#f}. Any object satisfying this predicate also satisfies\n" - "@code{port?}.") -#define FUNC_NAME s_scm_input_port_p -{ - return scm_from_bool (SCM_INPUT_PORT_P (x)); -} -#undef FUNC_NAME + if (!scm_conversion_strategy_init + || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) + handler = SCM_FAILED_CONVERSION_QUESTION_MARK; + else + { + SCM fluid, value; -SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is an output port, otherwise return\n" - "@code{#f}. Any object satisfying this predicate also satisfies\n" - "@code{port?}.") -#define FUNC_NAME s_scm_output_port_p -{ - x = SCM_COERCE_OUTPORT (x); - return scm_from_bool (SCM_OUTPUT_PORT_P (x)); -} -#undef FUNC_NAME + fluid = SCM_VARIABLE_REF (default_conversion_strategy_var); + value = scm_fluid_ref (fluid); -SCM_DEFINE (scm_port_p, "port?", 1, 0, 0, - (SCM x), - "Return a boolean indicating whether @var{x} is a port.\n" - "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n" - "@var{x}))}.") -#define FUNC_NAME s_scm_port_p -{ - return scm_from_bool (SCM_PORTP (x)); -} -#undef FUNC_NAME + if (scm_is_eq (sym_substitute, value)) + handler = SCM_FAILED_CONVERSION_QUESTION_MARK; + else if (scm_is_eq (sym_escape, value)) + handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + else + /* Default to 'error also when the fluid's value is not one of + the valid symbols. */ + handler = SCM_FAILED_CONVERSION_ERROR; + } -SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0, - (SCM port), - "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n" - "open.") -#define FUNC_NAME s_scm_port_closed_p -{ - SCM_VALIDATE_PORT (1, port); - return scm_from_bool (!SCM_OPPORTP (port)); + return handler; } -#undef FUNC_NAME -SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, - (SCM x), - "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n" - "return @code{#f}.") -#define FUNC_NAME s_scm_eof_object_p +/* Use HANDLER as the default conversion strategy for future ports. */ +void +scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler + handler) { - return scm_from_bool(SCM_EOF_OBJECT_P (x)); -} -#undef FUNC_NAME + SCM strategy; -SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, - (SCM port), - "Flush the specified output port, or the current output port if @var{port}\n" - "is omitted. The current output buffer contents are passed to the\n" - "underlying port implementation (e.g., in the case of fports, the\n" - "data will be written to the file and the output buffer will be cleared.)\n" - "It has no effect on an unbuffered port.\n\n" - "The return value is unspecified.") -#define FUNC_NAME s_scm_force_output -{ - if (SCM_UNBNDP (port)) - port = scm_current_output_port (); - else + if (!scm_conversion_strategy_init + || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) + scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", + SCM_EOL); + + switch (handler) { - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_OPOUTPORT (1, port); + case SCM_FAILED_CONVERSION_ERROR: + strategy = sym_error; + break; + + case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE: + strategy = sym_escape; + break; + + case SCM_FAILED_CONVERSION_QUESTION_MARK: + strategy = sym_substitute; + break; + + default: + abort (); } - scm_flush (port); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME + scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), + strategy); +} static void - finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data) -flush_output_port (void *closure, SCM port) ++finalize_iconv_descriptors (void *ptr, void *data) { - if (SCM_OPOUTPORTP (port)) - scm_flush (port); + close_iconv_descriptors (ptr); } -SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, - (), - "Equivalent to calling @code{force-output} on\n" - "all open output ports. The return value is unspecified.") -#define FUNC_NAME s_scm_flush_all_ports +static scm_t_iconv_descriptors * +open_iconv_descriptors (const char *encoding, int reading, int writing) { - scm_c_port_for_each (&flush_output_port, NULL); - return SCM_UNSPECIFIED; + scm_t_iconv_descriptors *id; + iconv_t input_cd, output_cd; + size_t i; + + input_cd = (iconv_t) -1; + output_cd = (iconv_t) -1; + + for (i = 0; encoding[i]; i++) + if (encoding[i] > 127) + goto invalid_encoding; + + if (reading) + { + /* Open an input iconv conversion descriptor, from ENCODING + to UTF-8. We choose UTF-8, not UTF-32, because iconv + implementations can typically convert from anything to + UTF-8, but not to UTF-32 (see + ). */ + + /* Assume opening an iconv descriptor causes about 16 KB of + allocation. */ + scm_gc_register_allocation (16 * 1024); + + input_cd = iconv_open ("UTF-8", encoding); + if (input_cd == (iconv_t) -1) + goto invalid_encoding; + } + + if (writing) + { + /* Assume opening an iconv descriptor causes about 16 KB of + allocation. */ + scm_gc_register_allocation (16 * 1024); + + output_cd = iconv_open (encoding, "UTF-8"); + if (output_cd == (iconv_t) -1) + { + if (input_cd != (iconv_t) -1) + iconv_close (input_cd); + goto invalid_encoding; + } + } + + id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors"); + id->input_cd = input_cd; + id->output_cd = output_cd; + + /* Register a finalizer to close the descriptors. */ + scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL); + + return id; + + invalid_encoding: + { + SCM err; + err = scm_from_latin1_string (encoding); + scm_misc_error ("open_iconv_descriptors", + "invalid or unknown character encoding ~s", + scm_list_1 (err)); + } } -#undef FUNC_NAME -SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, - (SCM port), - "Return the next character available from @var{port}, updating\n" - "@var{port} to point to the following character. If no more\n" - "characters are available, the end-of-file object is returned.\n" - "\n" - "When @var{port}'s data cannot be decoded according to its\n" - "character encoding, a @code{decoding-error} is raised and\n" - "@var{port} points past the erroneous byte sequence.\n") -#define FUNC_NAME s_scm_read_char +static void +close_iconv_descriptors (scm_t_iconv_descriptors *id) { - scm_t_wchar c; - if (SCM_UNBNDP (port)) - port = scm_current_input_port (); - SCM_VALIDATE_OPINPORT (1, port); - c = scm_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - return SCM_MAKE_CHAR (c); + if (id->input_cd != (iconv_t) -1) + iconv_close (id->input_cd); + if (id->output_cd != (iconv_t) -1) + iconv_close (id->output_cd); + id->input_cd = (void *) -1; + id->output_cd = (void *) -1; } -#undef FUNC_NAME -/* Update the line and column number of PORT after consumption of C. */ -static inline void -update_port_lf (scm_t_wchar c, SCM port) +scm_t_iconv_descriptors * +scm_i_port_iconv_descriptors (SCM port) { - switch (c) + scm_t_port *pt; + + pt = SCM_PTAB_ENTRY (port); + + assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV); + + if (!pt->iconv_descriptors) { - case '\a': - case EOF: - break; - case '\b': - SCM_DECCOL (port); - break; - case '\n': - SCM_INCLINE (port); - break; - case '\r': - SCM_ZEROCOL (port); - break; - case '\t': - SCM_TABCOL (port); - break; - default: - SCM_INCCOL (port); - break; + if (!pt->encoding) + pt->encoding = "ISO-8859-1"; + pt->iconv_descriptors = + open_iconv_descriptors (pt->encoding, + SCM_INPUT_PORT_P (port), + SCM_OUTPUT_PORT_P (port)); } -} -#define SCM_MBCHAR_BUF_SIZE (4) + return pt->iconv_descriptors; +} -/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint. - UTF8_BUF is assumed to contain a valid UTF-8 sequence. */ -static scm_t_wchar -utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size) +/* The name of the encoding is itself encoded in ASCII. */ +void +scm_i_set_port_encoding_x (SCM port, const char *encoding) { - scm_t_wchar codepoint; + scm_t_port *pt; + scm_t_iconv_descriptors *prev; - if (utf8_buf[0] <= 0x7f) - { - assert (size == 1); - codepoint = utf8_buf[0]; - } - else if ((utf8_buf[0] & 0xe0) == 0xc0) + /* Set the character encoding for this port. */ + pt = SCM_PTAB_ENTRY (port); + prev = pt->iconv_descriptors; + + if (encoding && strcmp (encoding, "UTF-8") == 0) { - assert (size == 2); - codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL - | (utf8_buf[1] & 0x3f); + pt->encoding = "UTF-8"; + pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8; + pt->iconv_descriptors = NULL; } - else if ((utf8_buf[0] & 0xf0) == 0xe0) + else if (!encoding || strcmp (encoding, "ISO-8859-1") == 0) { - assert (size == 3); - codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL - | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL - | (utf8_buf[2] & 0x3f); + pt->encoding = "ISO-8859-1"; + pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1; + pt->iconv_descriptors = NULL; } else { diff --cc libguile/weak-set.c index 33402b548,000000000..d648dbd34 mode 100644,000000..100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@@ -1,946 -1,0 +1,946 @@@ +/* Copyright (C) 2011, 2012 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/hash.h" +#include "libguile/eval.h" +#include "libguile/ports.h" +#include "libguile/bdw-gc.h" + +#include "libguile/validate.h" +#include "libguile/weak-set.h" + + +/* Weak Sets + + This file implements weak sets. One example of a weak set is the + symbol table, where you want all instances of the `foo' symbol to map + to one object. So when you load a file and it wants a symbol with + the characters "foo", you one up in the table, using custom hash and + equality predicates. Only if one is not found will you bother to + cons one up and intern it. + + Another use case for weak sets is the set of open ports. Guile needs + to be able to flush them all when the process exits, but the set + shouldn't prevent the GC from collecting the port (and thus closing + it). + + Weak sets are implemented using an open-addressed hash table. + Basically this means that there is an array of entries, and the item + is expected to be found the slot corresponding to its hash code, + modulo the length of the array. + + Collisions are handled using linear probing with the Robin Hood + technique. See Pedro Celis' paper, "Robin Hood Hashing": + + http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf + + The vector of entries is allocated as an "atomic" piece of memory, so + that the GC doesn't trace it. When an item is added to the set, a + disappearing link is registered to its location. If the item is + collected, then that link will be zeroed out. + + An entry is not just an item, though; the hash code is also stored in + the entry. We munge hash codes so that they are never 0. In this + way we can detect removed entries (key of zero but nonzero hash + code), and can then reshuffle elements as needed to maintain the + robin hood ordering. + + Compared to buckets-and-chains hash tables, open addressing has the + advantage that it is very cache-friendly. It also uses less memory. + + Implementation-wise, there are two things to note. + + 1. We assume that hash codes are evenly distributed across the + range of unsigned longs. The actual hash code stored in the + entry is left-shifted by 1 bit (losing 1 bit of hash precision), + and then or'd with 1. In this way we ensure that the hash field + of an occupied entry is nonzero. To map to an index, we + right-shift the hash by one, divide by the size, and take the + remainder. + + 2. Since the "keys" (the objects in the set) are stored in an + atomic region with disappearing links, they need to be accessed + with the GC alloc lock. `copy_weak_entry' will do that for + you. The hash code itself can be read outside the lock, + though. +*/ + + +typedef struct { + unsigned long hash; + scm_t_bits key; +} scm_t_weak_entry; + + +struct weak_entry_data { + scm_t_weak_entry *in; + scm_t_weak_entry *out; +}; + +static void* +do_copy_weak_entry (void *data) +{ + struct weak_entry_data *e = data; + + e->out->hash = e->in->hash; + e->out->key = e->in->key; + + return NULL; +} + +static void +copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst) +{ + struct weak_entry_data data; + + data.in = src; + data.out = dst; + + GC_call_with_alloc_lock (do_copy_weak_entry, &data); +} + + +typedef struct { + scm_t_weak_entry *entries; /* the data */ + scm_i_pthread_mutex_t lock; /* the lock */ + unsigned long size; /* total number of slots. */ + unsigned long n_items; /* number of items in set */ + unsigned long lower; /* when to shrink */ + unsigned long upper; /* when to grow */ + int size_index; /* index into hashset_size */ + int min_size_index; /* minimum size_index */ +} scm_t_weak_set; + + +#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set)) +#define SCM_VALIDATE_WEAK_SET(pos, arg) \ + SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set") +#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x)) + + +static unsigned long +hash_to_index (unsigned long hash, unsigned long size) +{ + return (hash >> 1) % size; +} + +static unsigned long +entry_distance (unsigned long hash, unsigned long k, unsigned long size) +{ + unsigned long origin = hash_to_index (hash, size); + + if (k >= origin) + return k - origin; + else + /* The other key was displaced and wrapped around. */ + return size - origin + k; +} + +static void +move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to) +{ + if (from->hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (from, ©); + to->hash = copy.hash; + to->key = copy.key; + + if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) + { +#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK - GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key); ++ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key); +#else - GC_unregister_disappearing_link ((GC_PTR) &from->key); - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key, - (GC_PTR) to->key); ++ GC_unregister_disappearing_link ((void **) &from->key); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key, ++ to->key); +#endif + } + } + else + { + to->hash = 0; + to->key = 0; + } +} + +static void +rob_from_rich (scm_t_weak_set *set, unsigned long k) +{ + unsigned long empty, size; + + size = set->size; + + /* If we are to free up slot K in the set, we need room to do so. */ + assert (set->n_items < size); + + empty = k; + do + empty = (empty + 1) % size; + /* Here we access key outside the lock. Is this a problem? At first + glance, I wouldn't think so. */ + while (set->entries[empty].key); + + do + { + unsigned long last = empty ? (empty - 1) : (size - 1); + move_weak_entry (&set->entries[last], &set->entries[empty]); + empty = last; + } + while (empty != k); + + /* Just for sanity. */ + set->entries[empty].hash = 0; + set->entries[empty].key = 0; +} + +static void +give_to_poor (scm_t_weak_set *set, unsigned long k) +{ + /* Slot K was just freed up; possibly shuffle others down. */ + unsigned long size = set->size; + + while (1) + { + unsigned long next = (k + 1) % size; + unsigned long hash; + scm_t_weak_entry copy; + + hash = set->entries[next].hash; + + if (!hash || hash_to_index (hash, size) == next) + break; + + copy_weak_entry (&set->entries[next], ©); + + if (!copy.key) + /* Lost weak reference. */ + { + give_to_poor (set, next); + set->n_items--; + continue; + } + + move_weak_entry (&set->entries[next], &set->entries[k]); + + k = next; + } + + /* We have shuffled down any entries that should be shuffled down; now + free the end. */ + set->entries[k].hash = 0; + set->entries[k].key = 0; +} + + + + +/* Growing or shrinking is triggered when the load factor + * + * L = N / S (N: number of items in set, S: bucket vector length) + * + * passes an upper limit of 0.9 or a lower limit of 0.2. + * + * The implementation stores the upper and lower number of items which + * trigger a resize in the hashset object. + * + * Possible hash set sizes (primes) are stored in the array + * hashset_size. + */ + +static unsigned long hashset_size[] = { + 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, + 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081, + 57524111, 115048217, 230096423 +}; + +#define HASHSET_SIZE_N (sizeof(hashset_size)/sizeof(unsigned long)) + +static int +compute_size_index (scm_t_weak_set *set) +{ + int i = set->size_index; + + if (set->n_items < set->lower) + { + /* rehashing is not triggered when i <= min_size */ + do + --i; + while (i > set->min_size_index + && set->n_items < hashset_size[i] / 5); + } + else if (set->n_items > set->upper) + { + ++i; + if (i >= HASHSET_SIZE_N) + /* The biggest size currently is 230096423, which for a 32-bit + machine will occupy 1.5GB of memory at a load of 80%. There + is probably something better to do here, but if you have a + weak map of that size, you are hosed in any case. */ + abort (); + } + + return i; +} + +static int +is_acceptable_size_index (scm_t_weak_set *set, int size_index) +{ + int computed = compute_size_index (set); + + if (size_index == computed) + /* We were going to grow or shrink, and allocating the new vector + didn't change the target size. */ + return 1; + + if (size_index == computed + 1) + { + /* We were going to enlarge the set, but allocating the new + vector finalized some objects, making an enlargement + unnecessary. It might still be a good idea to use the larger + set, though. (This branch also gets hit if, while allocating + the vector, some other thread was actively removing items from + the set. That is less likely, though.) */ + unsigned long new_lower = hashset_size[size_index] / 5; + + return set->size > new_lower; + } + + if (size_index == computed - 1) + { + /* We were going to shrink the set, but when we dropped the lock + to allocate the new vector, some other thread added elements to + the set. */ + return 0; + } + + /* The computed size differs from our newly allocated size by more + than one size index -- recalculate. */ + return 0; +} + +static void +resize_set (scm_t_weak_set *set) +{ + scm_t_weak_entry *old_entries, *new_entries; + int new_size_index; + unsigned long old_size, new_size, old_k; + + do + { + new_size_index = compute_size_index (set); + if (new_size_index == set->size_index) + return; + new_size = hashset_size[new_size_index]; + scm_i_pthread_mutex_unlock (&set->lock); + /* Allocating memory might cause finalizers to run, which could + run anything, so drop our lock to avoid deadlocks. */ + new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry), + "weak set"); + scm_i_pthread_mutex_lock (&set->lock); + } + while (!is_acceptable_size_index (set, new_size_index)); + + old_entries = set->entries; + old_size = set->size; + + memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry)); + + set->size_index = new_size_index; + set->size = new_size; + if (new_size_index <= set->min_size_index) + set->lower = 0; + else + set->lower = new_size / 5; + set->upper = 9 * new_size / 10; + set->n_items = 0; + set->entries = new_entries; + + for (old_k = 0; old_k < old_size; old_k++) + { + scm_t_weak_entry copy; + unsigned long new_k, distance; + + if (!old_entries[old_k].hash) + continue; + + copy_weak_entry (&old_entries[old_k], ©); + + if (!copy.key) + continue; + + new_k = hash_to_index (copy.hash, new_size); + + for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) + { + unsigned long other_hash = new_entries[new_k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, new_k, new_size) < distance) + { + rob_from_rich (set, new_k); + break; + } + } + + set->n_items++; + new_entries[new_k].hash = copy.hash; + new_entries[new_k].key = copy.key; + + if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &new_entries[new_k].key, - (GC_PTR) new_entries[new_k].key); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key, ++ (void *) new_entries[new_k].key); + } +} + +/* Run after GC via do_vacuum_weak_set, this function runs over the + whole table, removing lost weak references, reshuffling the set as it + goes. It might resize the set if it reaps enough entries. */ +static void +vacuum_weak_set (scm_t_weak_set *set) +{ + scm_t_weak_entry *entries = set->entries; + unsigned long size = set->size; + unsigned long k; + + for (k = 0; k < size; k++) + { + unsigned long hash = entries[k].hash; + + if (hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + } + } + } + + if (set->n_items < set->lower) + resize_set (set); +} + + + + +static SCM +weak_set_lookup (scm_t_weak_set *set, unsigned long hash, + scm_t_set_predicate_fn pred, void *closure, + SCM dflt) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = set->size; + entries = set->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return dflt; + + if (hash == other_hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), closure)) + /* Found. */ + return SCM_PACK (copy.key); + } + + /* If the entry's distance is less, our key is not in the set. */ + if (entry_distance (other_hash, k, size) < distance) + return dflt; + } + + /* If we got here, then we were unfortunate enough to loop through the + whole set. Shouldn't happen, but hey. */ + return dflt; +} + + +static SCM +weak_set_add_x (scm_t_weak_set *set, unsigned long hash, + scm_t_set_predicate_fn pred, void *closure, + SCM obj) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = set->size; + entries = set->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; ; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), closure)) + /* Found an entry with this key. */ + return SCM_PACK (copy.key); + } + + if (set->n_items > set->upper) + /* Full set, time to resize. */ + { + resize_set (set); + return weak_set_add_x (set, hash >> 1, pred, closure, obj); + } + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, k, size) < distance) + { + rob_from_rich (set, k); + break; + } + } + + set->n_items++; + entries[k].hash = hash; + entries[k].key = SCM_UNPACK (obj); + + if (SCM_HEAP_OBJECT_P (obj)) - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entries[k].key, - (GC_PTR) SCM2PTR (obj)); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key, ++ (void *) SCM2PTR (obj)); + + return obj; +} + + +static void +weak_set_remove_x (scm_t_weak_set *set, unsigned long hash, + scm_t_set_predicate_fn pred, void *closure) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = set->size; + entries = set->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), closure)) + /* Found an entry with this key. */ + { + entries[k].hash = 0; + entries[k].key = 0; + + if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key))) - GC_unregister_disappearing_link ((GC_PTR) &entries[k].key); ++ GC_unregister_disappearing_link ((void **) &entries[k].key); + + if (--set->n_items < set->lower) + resize_set (set); + else + give_to_poor (set, k); + + return; + } + } + + /* If the entry's distance is less, our key is not in the set. */ + if (entry_distance (other_hash, k, size) < distance) + return; + } +} + + + +static SCM +make_weak_set (unsigned long k) +{ + scm_t_weak_set *set; + + int i = 0, n = k ? k : 31; + while (i + 1 < HASHSET_SIZE_N && n > hashset_size[i]) + ++i; + n = hashset_size[i]; + + set = scm_gc_malloc (sizeof (*set), "weak-set"); + set->entries = scm_gc_malloc_pointerless (n * sizeof(scm_t_weak_entry), + "weak-set"); + memset (set->entries, 0, n * sizeof(scm_t_weak_entry)); + set->n_items = 0; + set->size = n; + set->lower = 0; + set->upper = 9 * n / 10; + set->size_index = i; + set->min_size_index = i; + scm_i_pthread_mutex_init (&set->lock, NULL); + + return scm_cell (scm_tc7_weak_set, (scm_t_bits)set); +} + +void +scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts_unlocked ("#<", port); + scm_puts_unlocked ("weak-set ", port); + scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port); + scm_putc_unlocked ('/', port); + scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port); + scm_puts_unlocked (">", port); +} + +static void +do_vacuum_weak_set (SCM set) +{ + scm_t_weak_set *s; + + s = SCM_WEAK_SET (set); + + if (scm_i_pthread_mutex_trylock (&s->lock) == 0) + { + vacuum_weak_set (s); + scm_i_pthread_mutex_unlock (&s->lock); + } + + return; +} + +/* The before-gc C hook only runs if GC_set_start_callback is available, + so if not, fall back on a finalizer-based implementation. */ +static int +weak_gc_callback (void **weak) +{ + void *val = weak[0]; + void (*callback) (SCM) = weak[1]; + + if (!val) + return 0; + + callback (SCM_PACK_POINTER (val)); + + return 1; +} + +#ifdef HAVE_GC_SET_START_CALLBACK +static void* +weak_gc_hook (void *hook_data, void *fn_data, void *data) +{ + if (!weak_gc_callback (fn_data)) + scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data); + + return NULL; +} +#else +static void +weak_gc_finalizer (void *ptr, void *data) +{ + if (weak_gc_callback (ptr)) + scm_i_set_finalizer (ptr, weak_gc_finalizer, data); +} +#endif + +static void +scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) +{ + void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); + + weak[0] = SCM_UNPACK_POINTER (obj); + weak[1] = (void*)callback; + GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); + +#ifdef HAVE_GC_SET_START_CALLBACK + scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0); +#else + scm_i_set_finalizer (weak, weak_gc_finalizer, NULL); +#endif +} + +SCM +scm_c_make_weak_set (unsigned long k) +{ + SCM ret; + + ret = make_weak_set (k); + + scm_c_register_weak_gc_callback (ret, do_vacuum_weak_set); + + return ret; +} + +SCM +scm_weak_set_p (SCM obj) +{ + return scm_from_bool (SCM_WEAK_SET_P (obj)); +} + +SCM +scm_weak_set_clear_x (SCM set) +{ + scm_t_weak_set *s = SCM_WEAK_SET (set); + + scm_i_pthread_mutex_lock (&s->lock); + + memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size); + s->n_items = 0; + + scm_i_pthread_mutex_unlock (&s->lock); + + return SCM_UNSPECIFIED; +} + +SCM +scm_c_weak_set_lookup (SCM set, unsigned long raw_hash, + scm_t_set_predicate_fn pred, + void *closure, SCM dflt) +{ + SCM ret; + scm_t_weak_set *s = SCM_WEAK_SET (set); + + scm_i_pthread_mutex_lock (&s->lock); + + ret = weak_set_lookup (s, raw_hash, pred, closure, dflt); + + scm_i_pthread_mutex_unlock (&s->lock); + + return ret; +} + +SCM +scm_c_weak_set_add_x (SCM set, unsigned long raw_hash, + scm_t_set_predicate_fn pred, + void *closure, SCM obj) +{ + SCM ret; + scm_t_weak_set *s = SCM_WEAK_SET (set); + + scm_i_pthread_mutex_lock (&s->lock); + + ret = weak_set_add_x (s, raw_hash, pred, closure, obj); + + scm_i_pthread_mutex_unlock (&s->lock); + + return ret; +} + +void +scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash, + scm_t_set_predicate_fn pred, + void *closure) +{ + scm_t_weak_set *s = SCM_WEAK_SET (set); + + scm_i_pthread_mutex_lock (&s->lock); + + weak_set_remove_x (s, raw_hash, pred, closure); + + scm_i_pthread_mutex_unlock (&s->lock); +} + +static int +eq_predicate (SCM x, void *closure) +{ + return scm_is_eq (x, SCM_PACK_POINTER (closure)); +} + +SCM +scm_weak_set_add_x (SCM set, SCM obj) +{ + return scm_c_weak_set_add_x (set, scm_ihashq (obj, -1), + eq_predicate, SCM_UNPACK_POINTER (obj), obj); +} + +SCM +scm_weak_set_remove_x (SCM set, SCM obj) +{ + scm_c_weak_set_remove_x (set, scm_ihashq (obj, -1), + eq_predicate, SCM_UNPACK_POINTER (obj)); + + return SCM_UNSPECIFIED; +} + +SCM +scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure, + SCM init, SCM set) +{ + scm_t_weak_set *s; + scm_t_weak_entry *entries; + unsigned long k, size; + + s = SCM_WEAK_SET (set); + + scm_i_pthread_mutex_lock (&s->lock); + + size = s->size; + entries = s->entries; + + for (k = 0; k < size; k++) + { + if (entries[k].hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (copy.key) + { + /* Release set lock while we call the function. */ + scm_i_pthread_mutex_unlock (&s->lock); + init = proc (closure, SCM_PACK (copy.key), init); + scm_i_pthread_mutex_lock (&s->lock); + } + } + } + + scm_i_pthread_mutex_unlock (&s->lock); + + return init; +} + +static SCM +fold_trampoline (void *closure, SCM item, SCM init) +{ + return scm_call_2 (SCM_PACK_POINTER (closure), item, init); +} + +SCM +scm_weak_set_fold (SCM proc, SCM init, SCM set) +{ + return scm_c_weak_set_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, set); +} + +static SCM +for_each_trampoline (void *closure, SCM item, SCM seed) +{ + scm_call_1 (SCM_PACK_POINTER (closure), item); + return seed; +} + +SCM +scm_weak_set_for_each (SCM proc, SCM set) +{ + scm_c_weak_set_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, set); + + return SCM_UNSPECIFIED; +} + +static SCM +map_trampoline (void *closure, SCM item, SCM seed) +{ + return scm_cons (scm_call_1 (SCM_PACK_POINTER (closure), item), seed); +} + +SCM +scm_weak_set_map_to_list (SCM proc, SCM set) +{ + return scm_c_weak_set_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, set); +} + + +void +scm_init_weak_set () +{ +#include "libguile/weak-set.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --cc libguile/weak-table.c index be73e1bfa,000000000..9ef6674e1 mode 100644,000000..100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@@ -1,1208 -1,0 +1,1208 @@@ +/* Copyright (C) 2011, 2012 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/bdw-gc.h" +#include + +#include "libguile/_scm.h" +#include "libguile/hash.h" +#include "libguile/eval.h" +#include "libguile/ports.h" + +#include "libguile/validate.h" +#include "libguile/weak-table.h" + + +/* Weak Tables + + This file implements weak hash tables. Weak hash tables are + generally used when you want to augment some object with additional + data, but when you don't have space to store the data in the object. + For example, procedure properties are implemented with weak tables. + + Weak tables are implemented using an open-addressed hash table. + Basically this means that there is an array of entries, and the item + is expected to be found the slot corresponding to its hash code, + modulo the length of the array. + + Collisions are handled using linear probing with the Robin Hood + technique. See Pedro Celis' paper, "Robin Hood Hashing": + + http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf + + The vector of entries is allocated in such a way that the GC doesn't + trace the weak values. For doubly-weak tables, this means that the + entries are allocated as an "atomic" piece of memory. Key-weak and + value-weak tables use a special GC kind with a custom mark procedure. + When items are added weakly into table, a disappearing link is + registered to their locations. If the referent is collected, then + that link will be zeroed out. + + An entry in the table consists of the key and the value, together + with the hash code of the key. We munge hash codes so that they are + never 0. In this way we can detect removed entries (key of zero but + nonzero hash code), and can then reshuffle elements as needed to + maintain the robin hood ordering. + + Compared to buckets-and-chains hash tables, open addressing has the + advantage that it is very cache-friendly. It also uses less memory. + + Implementation-wise, there are two things to note. + + 1. We assume that hash codes are evenly distributed across the + range of unsigned longs. The actual hash code stored in the + entry is left-shifted by 1 bit (losing 1 bit of hash precision), + and then or'd with 1. In this way we ensure that the hash field + of an occupied entry is nonzero. To map to an index, we + right-shift the hash by one, divide by the size, and take the + remainder. + + 2. Since the weak references are stored in an atomic region with + disappearing links, they need to be accessed with the GC alloc + lock. `copy_weak_entry' will do that for you. The hash code + itself can be read outside the lock, though. + */ + + +typedef struct { + unsigned long hash; + scm_t_bits key; + scm_t_bits value; +} scm_t_weak_entry; + + +struct weak_entry_data { + scm_t_weak_entry *in; + scm_t_weak_entry *out; +}; + +static void* +do_copy_weak_entry (void *data) +{ + struct weak_entry_data *e = data; + + e->out->hash = e->in->hash; + e->out->key = e->in->key; + e->out->value = e->in->value; + + return NULL; +} + +static void +copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst) +{ + struct weak_entry_data data; + + data.in = src; + data.out = dst; + + GC_call_with_alloc_lock (do_copy_weak_entry, &data); +} + +static void +register_disappearing_links (scm_t_weak_entry *entry, + SCM k, SCM v, + scm_t_weak_table_kind kind) +{ + if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k) + && (kind == SCM_WEAK_TABLE_KIND_KEY + || kind == SCM_WEAK_TABLE_KIND_BOTH)) - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key, - (GC_PTR) SCM2PTR (k)); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key, ++ SCM2PTR (k)); + + if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v) + && (kind == SCM_WEAK_TABLE_KIND_VALUE + || kind == SCM_WEAK_TABLE_KIND_BOTH)) - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value, - (GC_PTR) SCM2PTR (v)); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value, ++ SCM2PTR (v)); +} + +static void +unregister_disappearing_links (scm_t_weak_entry *entry, + scm_t_weak_table_kind kind) +{ + if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) - GC_unregister_disappearing_link ((GC_PTR) &entry->key); ++ GC_unregister_disappearing_link ((void **) &entry->key); + + if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) - GC_unregister_disappearing_link ((GC_PTR) &entry->value); ++ GC_unregister_disappearing_link ((void **) &entry->value); +} + +static void +move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to, + SCM key, SCM value, scm_t_weak_table_kind kind) +{ + if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH) + && SCM_HEAP_OBJECT_P (key)) + { +#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK - GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key); ++ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key); +#else - GC_unregister_disappearing_link (&from->key); - SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key)); ++ GC_unregister_disappearing_link ((void **) &from->key); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->key, SCM2PTR (key)); +#endif + } + + if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH) + && SCM_HEAP_OBJECT_P (value)) + { +#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK - GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value); ++ GC_move_disappearing_link ((void **) &from->value, (void **) &to->value); +#else - GC_unregister_disappearing_link (&from->value); - SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value)); ++ GC_unregister_disappearing_link ((void **) &from->value); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &to->value, SCM2PTR (value)); +#endif + } +} + +static void +move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to, + scm_t_weak_table_kind kind) +{ + if (from->hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (from, ©); + to->hash = copy.hash; + to->key = copy.key; + to->value = copy.value; + + move_disappearing_links (from, to, + SCM_PACK (copy.key), SCM_PACK (copy.value), + kind); + } + else + { + to->hash = 0; + to->key = 0; + to->value = 0; + } +} + + +typedef struct { + scm_t_weak_entry *entries; /* the data */ + scm_i_pthread_mutex_t lock; /* the lock */ + scm_t_weak_table_kind kind; /* what kind of table it is */ + unsigned long size; /* total number of slots. */ + unsigned long n_items; /* number of items in table */ + unsigned long lower; /* when to shrink */ + unsigned long upper; /* when to grow */ + int size_index; /* index into hashtable_size */ + int min_size_index; /* minimum size_index */ +} scm_t_weak_table; + + +#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table)) +#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \ + SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table") +#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x)) + + +static unsigned long +hash_to_index (unsigned long hash, unsigned long size) +{ + return (hash >> 1) % size; +} + +static unsigned long +entry_distance (unsigned long hash, unsigned long k, unsigned long size) +{ + unsigned long origin = hash_to_index (hash, size); + + if (k >= origin) + return k - origin; + else + /* The other key was displaced and wrapped around. */ + return size - origin + k; +} + +static void +rob_from_rich (scm_t_weak_table *table, unsigned long k) +{ + unsigned long empty, size; + + size = table->size; + + /* If we are to free up slot K in the table, we need room to do so. */ + assert (table->n_items < size); + + empty = k; + do + empty = (empty + 1) % size; + while (table->entries[empty].hash); + + do + { + unsigned long last = empty ? (empty - 1) : (size - 1); + move_weak_entry (&table->entries[last], &table->entries[empty], + table->kind); + empty = last; + } + while (empty != k); + + table->entries[empty].hash = 0; + table->entries[empty].key = 0; + table->entries[empty].value = 0; +} + +static void +give_to_poor (scm_t_weak_table *table, unsigned long k) +{ + /* Slot K was just freed up; possibly shuffle others down. */ + unsigned long size = table->size; + + while (1) + { + unsigned long next = (k + 1) % size; + unsigned long hash; + scm_t_weak_entry copy; + + hash = table->entries[next].hash; + + if (!hash || hash_to_index (hash, size) == next) + break; + + copy_weak_entry (&table->entries[next], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference. */ + { + give_to_poor (table, next); + table->n_items--; + continue; + } + + move_weak_entry (&table->entries[next], &table->entries[k], + table->kind); + + k = next; + } + + /* We have shuffled down any entries that should be shuffled down; now + free the end. */ + table->entries[k].hash = 0; + table->entries[k].key = 0; + table->entries[k].value = 0; +} + + + + +/* The GC "kinds" for singly-weak tables. */ +static int weak_key_gc_kind; +static int weak_value_gc_kind; + +static struct GC_ms_entry * +mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; + unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); + + for (k = 0; k < size; k++) + if (entries[k].hash && entries[k].key) + { + SCM value = SCM_PACK (entries[k].value); + mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value), + mark_stack_ptr, mark_stack_limit, + NULL); + } + + return mark_stack_ptr; +} + +static struct GC_ms_entry * +mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; + unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); + + for (k = 0; k < size; k++) + if (entries[k].hash && entries[k].value) + { + SCM key = SCM_PACK (entries[k].key); + mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key), + mark_stack_ptr, mark_stack_limit, + NULL); + } + + return mark_stack_ptr; +} + +static scm_t_weak_entry * +allocate_entries (unsigned long size, scm_t_weak_table_kind kind) +{ + scm_t_weak_entry *ret; + size_t bytes = size * sizeof (*ret); + + switch (kind) + { + case SCM_WEAK_TABLE_KIND_KEY: + ret = GC_generic_malloc (bytes, weak_key_gc_kind); + break; + case SCM_WEAK_TABLE_KIND_VALUE: + ret = GC_generic_malloc (bytes, weak_value_gc_kind); + break; + case SCM_WEAK_TABLE_KIND_BOTH: + ret = scm_gc_malloc_pointerless (bytes, "weak-table"); + break; + default: + abort (); + } + + memset (ret, 0, bytes); + + return ret; +} + + + +/* Growing or shrinking is triggered when the load factor + * + * L = N / S (N: number of items in table, S: bucket vector length) + * + * passes an upper limit of 0.9 or a lower limit of 0.2. + * + * The implementation stores the upper and lower number of items which + * trigger a resize in the hashtable object. + * + * Possible hash table sizes (primes) are stored in the array + * hashtable_size. + */ + +static unsigned long hashtable_size[] = { + 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, + 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081, + 57524111, 115048217, 230096423 +}; + +#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long)) + +static int +compute_size_index (scm_t_weak_table *table) +{ + int i = table->size_index; + + if (table->n_items < table->lower) + { + /* rehashing is not triggered when i <= min_size */ + do + --i; + while (i > table->min_size_index + && table->n_items < hashtable_size[i] / 5); + } + else if (table->n_items > table->upper) + { + ++i; + if (i >= HASHTABLE_SIZE_N) + /* The biggest size currently is 230096423, which for a 32-bit + machine will occupy 2.3GB of memory at a load of 80%. There + is probably something better to do here, but if you have a + weak map of that size, you are hosed in any case. */ + abort (); + } + + return i; +} + +static int +is_acceptable_size_index (scm_t_weak_table *table, int size_index) +{ + int computed = compute_size_index (table); + + if (size_index == computed) + /* We were going to grow or shrink, and allocating the new vector + didn't change the target size. */ + return 1; + + if (size_index == computed + 1) + { + /* We were going to enlarge the table, but allocating the new + vector finalized some objects, making an enlargement + unnecessary. It might still be a good idea to use the larger + table, though. (This branch also gets hit if, while allocating + the vector, some other thread was actively removing items from + the table. That is less likely, though.) */ + unsigned long new_lower = hashtable_size[size_index] / 5; + + return table->size > new_lower; + } + + if (size_index == computed - 1) + { + /* We were going to shrink the table, but when we dropped the lock + to allocate the new vector, some other thread added elements to + the table. */ + return 0; + } + + /* The computed size differs from our newly allocated size by more + than one size index -- recalculate. */ + return 0; +} + +static void +resize_table (scm_t_weak_table *table) +{ + scm_t_weak_entry *old_entries, *new_entries; + int new_size_index; + unsigned long old_size, new_size, old_k; + + do + { + new_size_index = compute_size_index (table); + if (new_size_index == table->size_index) + return; + new_size = hashtable_size[new_size_index]; + scm_i_pthread_mutex_unlock (&table->lock); + /* Allocating memory might cause finalizers to run, which could + run anything, so drop our lock to avoid deadlocks. */ + new_entries = allocate_entries (new_size, table->kind); + scm_i_pthread_mutex_lock (&table->lock); + } + while (!is_acceptable_size_index (table, new_size_index)); + + old_entries = table->entries; + old_size = table->size; + + table->size_index = new_size_index; + table->size = new_size; + if (new_size_index <= table->min_size_index) + table->lower = 0; + else + table->lower = new_size / 5; + table->upper = 9 * new_size / 10; + table->n_items = 0; + table->entries = new_entries; + + for (old_k = 0; old_k < old_size; old_k++) + { + scm_t_weak_entry copy; + unsigned long new_k, distance; + + if (!old_entries[old_k].hash) + continue; + + copy_weak_entry (&old_entries[old_k], ©); + + if (!copy.key || !copy.value) + continue; + + new_k = hash_to_index (copy.hash, new_size); + + for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) + { + unsigned long other_hash = new_entries[new_k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, new_k, new_size) < distance) + { + rob_from_rich (table, new_k); + break; + } + } + + table->n_items++; + new_entries[new_k].hash = copy.hash; + new_entries[new_k].key = copy.key; + new_entries[new_k].value = copy.value; + + register_disappearing_links (&new_entries[new_k], + SCM_PACK (copy.key), SCM_PACK (copy.value), + table->kind); + } +} + +/* Run after GC via do_vacuum_weak_table, this function runs over the + whole table, removing lost weak references, reshuffling the table as it + goes. It might resize the table if it reaps enough entries. */ +static void +vacuum_weak_table (scm_t_weak_table *table) +{ + scm_t_weak_entry *entries = table->entries; + unsigned long size = table->size; + unsigned long k; + + for (k = 0; k < size; k++) + { + unsigned long hash = entries[k].hash; + + if (hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + } + } + } + + if (table->n_items < table->lower) + resize_table (table); +} + + + + +static SCM +weak_table_ref (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure, + SCM dflt) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return dflt; + + if (hash == other_hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found. */ + return SCM_PACK (copy.value); + } + + /* If the entry's distance is less, our key is not in the table. */ + if (entry_distance (other_hash, k, size) < distance) + return dflt; + } + + /* If we got here, then we were unfortunate enough to loop through the + whole table. Shouldn't happen, but hey. */ + return dflt; +} + + +static void +weak_table_put_x (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure, + SCM key, SCM value) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; ; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found an entry with this key. */ + break; + } + + if (table->n_items > table->upper) + /* Full table, time to resize. */ + { + resize_table (table); + return weak_table_put_x (table, hash >> 1, pred, closure, key, value); + } + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, k, size) < distance) + { + rob_from_rich (table, k); + break; + } + } + + if (entries[k].hash) + unregister_disappearing_links (&entries[k], table->kind); + else + table->n_items++; + + entries[k].hash = hash; + entries[k].key = SCM_UNPACK (key); + entries[k].value = SCM_UNPACK (value); + + register_disappearing_links (&entries[k], key, value, table->kind); +} + + +static void +weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found an entry with this key. */ + { + entries[k].hash = 0; + entries[k].key = 0; + entries[k].value = 0; + + unregister_disappearing_links (&entries[k], table->kind); + + if (--table->n_items < table->lower) + resize_table (table); + else + give_to_poor (table, k); + + return; + } + } + + /* If the entry's distance is less, our key is not in the table. */ + if (entry_distance (other_hash, k, size) < distance) + return; + } +} + + + +static SCM +make_weak_table (unsigned long k, scm_t_weak_table_kind kind) +{ + scm_t_weak_table *table; + + int i = 0, n = k ? k : 31; + while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) + ++i; + n = hashtable_size[i]; + + table = scm_gc_malloc (sizeof (*table), "weak-table"); + table->entries = allocate_entries (n, kind); + table->kind = kind; + table->n_items = 0; + table->size = n; + table->lower = 0; + table->upper = 9 * n / 10; + table->size_index = i; + table->min_size_index = i; + scm_i_pthread_mutex_init (&table->lock, NULL); + + return scm_cell (scm_tc7_weak_table, (scm_t_bits)table); +} + +void +scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts_unlocked ("#<", port); + scm_puts_unlocked ("weak-table ", port); + scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); + scm_putc_unlocked ('/', port); + scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); + scm_puts_unlocked (">", port); +} + +static void +do_vacuum_weak_table (SCM table) +{ + scm_t_weak_table *t; + + t = SCM_WEAK_TABLE (table); + + if (scm_i_pthread_mutex_trylock (&t->lock) == 0) + { + vacuum_weak_table (t); + scm_i_pthread_mutex_unlock (&t->lock); + } + + return; +} + +/* The before-gc C hook only runs if GC_table_start_callback is available, + so if not, fall back on a finalizer-based implementation. */ +static int +weak_gc_callback (void **weak) +{ + void *val = weak[0]; + void (*callback) (SCM) = weak[1]; + + if (!val) + return 0; + + callback (SCM_PACK_POINTER (val)); + + return 1; +} + +#ifdef HAVE_GC_TABLE_START_CALLBACK +static void* +weak_gc_hook (void *hook_data, void *fn_data, void *data) +{ + if (!weak_gc_callback (fn_data)) + scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data); + + return NULL; +} +#else +static void +weak_gc_finalizer (void *ptr, void *data) +{ + if (weak_gc_callback (ptr)) + scm_i_set_finalizer (ptr, weak_gc_finalizer, data); +} +#endif + +static void +scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) +{ + void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); + + weak[0] = SCM_UNPACK_POINTER (obj); + weak[1] = (void*)callback; + GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); + +#ifdef HAVE_GC_TABLE_START_CALLBACK + scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0); +#else + scm_i_set_finalizer (weak, weak_gc_finalizer, NULL); +#endif +} + +SCM +scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) +{ + SCM ret; + + ret = make_weak_table (k, kind); + + scm_c_register_weak_gc_callback (ret, do_vacuum_weak_table); + + return ret; +} + +SCM +scm_weak_table_p (SCM obj) +{ + return scm_from_bool (SCM_WEAK_TABLE_P (obj)); +} + +SCM +scm_c_weak_table_ref (SCM table, unsigned long raw_hash, + scm_t_table_predicate_fn pred, + void *closure, SCM dflt) +#define FUNC_NAME "weak-table-ref" +{ + SCM ret; + scm_t_weak_table *t; + + SCM_VALIDATE_WEAK_TABLE (1, table); + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + ret = weak_table_ref (t, raw_hash, pred, closure, dflt); + + scm_i_pthread_mutex_unlock (&t->lock); + + return ret; +} +#undef FUNC_NAME + +void +scm_c_weak_table_put_x (SCM table, unsigned long raw_hash, + scm_t_table_predicate_fn pred, + void *closure, SCM key, SCM value) +#define FUNC_NAME "weak-table-put!" +{ + scm_t_weak_table *t; + + SCM_VALIDATE_WEAK_TABLE (1, table); + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + weak_table_put_x (t, raw_hash, pred, closure, key, value); + + scm_i_pthread_mutex_unlock (&t->lock); +} +#undef FUNC_NAME + +void +scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash, + scm_t_table_predicate_fn pred, + void *closure) +#define FUNC_NAME "weak-table-remove!" +{ + scm_t_weak_table *t; + + SCM_VALIDATE_WEAK_TABLE (1, table); + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + weak_table_remove_x (t, raw_hash, pred, closure); + + scm_i_pthread_mutex_unlock (&t->lock); +} +#undef FUNC_NAME + +static int +assq_predicate (SCM x, SCM y, void *closure) +{ + return scm_is_eq (x, SCM_PACK_POINTER (closure)); +} + +SCM +scm_weak_table_refq (SCM table, SCM key, SCM dflt) +{ + if (SCM_UNBNDP (dflt)) + dflt = SCM_BOOL_F; + + return scm_c_weak_table_ref (table, scm_ihashq (key, -1), + assq_predicate, SCM_UNPACK_POINTER (key), + dflt); +} + +void +scm_weak_table_putq_x (SCM table, SCM key, SCM value) +{ + scm_c_weak_table_put_x (table, scm_ihashq (key, -1), + assq_predicate, SCM_UNPACK_POINTER (key), + key, value); +} + +void +scm_weak_table_remq_x (SCM table, SCM key) +{ + scm_c_weak_table_remove_x (table, scm_ihashq (key, -1), + assq_predicate, SCM_UNPACK_POINTER (key)); +} + +void +scm_weak_table_clear_x (SCM table) +#define FUNC_NAME "weak-table-clear!" +{ + scm_t_weak_table *t; + + SCM_VALIDATE_WEAK_TABLE (1, table); + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size); + t->n_items = 0; + + scm_i_pthread_mutex_unlock (&t->lock); +} +#undef FUNC_NAME + +SCM +scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure, + SCM init, SCM table) +{ + scm_t_weak_table *t; + scm_t_weak_entry *entries; + unsigned long k, size; + + t = SCM_WEAK_TABLE (table); + + scm_i_pthread_mutex_lock (&t->lock); + + size = t->size; + entries = t->entries; + + for (k = 0; k < size; k++) + { + if (entries[k].hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (copy.key && copy.value) + { + /* Release table lock while we call the function. */ + scm_i_pthread_mutex_unlock (&t->lock); + init = proc (closure, + SCM_PACK (copy.key), SCM_PACK (copy.value), + init); + scm_i_pthread_mutex_lock (&t->lock); + } + } + } + + scm_i_pthread_mutex_unlock (&t->lock); + + return init; +} + +static SCM +fold_trampoline (void *closure, SCM k, SCM v, SCM init) +{ + return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init); +} + +SCM +scm_weak_table_fold (SCM proc, SCM init, SCM table) +#define FUNC_NAME "weak-table-fold" +{ + SCM_VALIDATE_WEAK_TABLE (3, table); + SCM_VALIDATE_PROC (1, proc); + + return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table); +} +#undef FUNC_NAME + +static SCM +for_each_trampoline (void *closure, SCM k, SCM v, SCM seed) +{ + scm_call_2 (SCM_PACK_POINTER (closure), k, v); + return seed; +} + +void +scm_weak_table_for_each (SCM proc, SCM table) +#define FUNC_NAME "weak-table-for-each" +{ + SCM_VALIDATE_WEAK_TABLE (2, table); + SCM_VALIDATE_PROC (1, proc); + + scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table); +} +#undef FUNC_NAME + +static SCM +map_trampoline (void *closure, SCM k, SCM v, SCM seed) +{ + return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed); +} + +SCM +scm_weak_table_map_to_list (SCM proc, SCM table) +#define FUNC_NAME "weak-table-map->list" +{ + SCM_VALIDATE_WEAK_TABLE (2, table); + SCM_VALIDATE_PROC (1, proc); + + return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table); +} +#undef FUNC_NAME + + + + +/* Legacy interface. */ + +SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, + (SCM n), + "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" + "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" + "Return a weak hash table with @var{size} buckets.\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_hash_table +{ + return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), + SCM_WEAK_TABLE_KIND_KEY); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, + (SCM n), + "Return a hash table with weak values with @var{size} buckets.\n" + "(@pxref{Hash Tables})") +#define FUNC_NAME s_scm_make_weak_value_hash_table +{ + return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), + SCM_WEAK_TABLE_KIND_VALUE); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, + (SCM n), + "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_hash_table +{ + return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), + SCM_WEAK_TABLE_KIND_BOTH); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, + (SCM obj), + "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" + "@deffnx {Scheme Procedure} doubly-weak-hash-table? 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_hash_table_p +{ + return scm_from_bool (SCM_WEAK_TABLE_P (obj) && + SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a weak value hash table.") +#define FUNC_NAME s_scm_weak_value_hash_table_p +{ + return scm_from_bool (SCM_WEAK_TABLE_P (obj) && + SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a doubly weak hash table.") +#define FUNC_NAME s_scm_doubly_weak_hash_table_p +{ + return scm_from_bool (SCM_WEAK_TABLE_P (obj) && + SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH); +} +#undef FUNC_NAME + + + + + +void +scm_weak_table_prehistory (void) +{ + weak_key_gc_kind = + GC_new_kind (GC_new_free_list (), + GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0), + 0, 0); + weak_value_gc_kind = + GC_new_kind (GC_new_free_list (), + GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0), + 0, 0); +} + +void +scm_init_weak_table () +{ +#include "libguile/weak-table.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --cc libguile/weak-vector.c index 23bc386d4,000000000..3e90b3d57 mode 100644,000000..100644 --- a/libguile/weak-vector.c +++ b/libguile/weak-vector.c @@@ -1,207 -1,0 +1,207 @@@ - /* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ++/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011, 2012 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/validate.h" + + + +/* {Weak Vectors} + */ + +#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) + +static SCM +make_weak_vector (size_t len, SCM fill) +#define FUNC_NAME "make-weak-vector" +{ + SCM wv; + size_t j; + + SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH); + + if (SCM_UNBNDP (fill)) + fill = SCM_UNSPECIFIED; + + wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM), + "weak vector")); + + SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect); + + if (SCM_HEAP_OBJECT_P (fill)) + { + memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM)); + for (j = 0; j < len; j++) + scm_c_weak_vector_set_x (wv, j, fill); + } + else + for (j = 0; j < len; j++) + SCM_SIMPLE_VECTOR_SET (wv, j, fill); + + return wv; +} +#undef FUNC_NAME + +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 make_weak_vector (scm_to_size_t (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 lst), + "@deffnx {Scheme Procedure} list->weak-vector lst\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 +{ + SCM wv; + size_t i; + long c_size; + + SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size); + + wv = make_weak_vector ((size_t) c_size, SCM_BOOL_F); + + for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++) + scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst)); + + return wv; +} +#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)); +} +#undef FUNC_NAME + + +struct weak_vector_ref_data +{ + SCM wv; + size_t k; +}; + +static void* +weak_vector_ref (void *data) +{ + struct weak_vector_ref_data *d = data; + + return SCM_SIMPLE_VECTOR_REF (d->wv, d->k); +} + +SCM +scm_c_weak_vector_ref (SCM wv, size_t k) +{ + struct weak_vector_ref_data d; + void *ret; + + d.wv = wv; + d.k = k; + + if (k >= SCM_I_VECTOR_LENGTH (wv)) + scm_out_of_range (NULL, scm_from_size_t (k)); + + ret = GC_call_with_alloc_lock (weak_vector_ref, &d); + + if (ret) + return SCM_PACK_POINTER (ret); + else + return SCM_BOOL_F; +} + + +void +scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x) +{ + SCM *elts; + struct weak_vector_ref_data d; + void *prev; + + d.wv = wv; + d.k = k; + + if (k >= SCM_I_VECTOR_LENGTH (wv)) + scm_out_of_range (NULL, scm_from_size_t (k)); + + prev = GC_call_with_alloc_lock (weak_vector_ref, &d); + + elts = SCM_I_VECTOR_WELTS (wv); + + if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev))) - GC_unregister_disappearing_link ((GC_PTR) &elts[k]); ++ GC_unregister_disappearing_link ((void **) &elts[k]); + + elts[k] = x; + + if (SCM_HEAP_OBJECT_P (x)) - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k], - (GC_PTR) SCM2PTR (x)); ++ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k], ++ SCM2PTR (x)); +} + + + +static void +scm_init_weak_vector_builtins (void) +{ +#ifndef SCM_MAGIC_SNARFER +#include "libguile/weak-vector.x" +#endif +} + +void +scm_init_weak_vectors () +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_weak_vector_builtins", + (scm_t_extension_init_func)scm_init_weak_vector_builtins, + NULL); +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --cc module/language/ecmascript/compile-tree-il.scm index 0914f920a,b5f0a3528..2fe0d924e --- a/module/language/ecmascript/compile-tree-il.scm +++ b/module/language/ecmascript/compile-tree-il.scm @@@ -70,6 -70,26 +70,26 @@@ (set-source-properties! res (location x)))) res))) + (define current-return-tag (make-parameter #f)) + + (define (return expr) + (-> (abort (or (current-return-tag) (error "return outside function")) + (list expr) + (-> (const '()))))) + + (define (with-return-prompt body-thunk) + (let ((tag (gensym "return"))) + (parameterize ((current-return-tag + (-> (lexical 'return tag)))) + (-> (let '(return) (list tag) - (list (-> (apply (-> (primitive 'make-prompt-tag))))) ++ (list (-> (primcall 'make-prompt-tag))) + (-> (prompt (current-return-tag) + (body-thunk) + (let ((val (gensym "val"))) + (-> (lambda-case + `(((k val) #f #f #f () (,(gensym) ,val)) + ,(-> (lexical 'val val))))))))))))) + (define (comp x e) (let ((l (location x))) (define (let1 what proc) @@@ -349,25 -371,24 +371,24 @@@ ,@(map (lambda (x) (comp x e)) args)) e)) ((call ,proc ,args) - `(apply ,(comp proc e) - ,@(map (lambda (x) (comp x e)) args))) + `(call ,(comp proc e) + ,@(map (lambda (x) (comp x e)) args))) ((return ,expr) - (-> (call (-> (primitive 'return)) - (comp expr e)))) + (return (comp expr e))) ((array . ,args) - `(apply ,(@implv new-array) - ,@(map (lambda (x) (comp x e)) args))) + `(call ,(@implv new-array) + ,@(map (lambda (x) (comp x e)) args))) ((object . ,args) - `(apply ,(@implv new-object) - ,@(map (lambda (x) - (pmatch x - ((,prop ,val) - (-> (apply (-> (primitive 'cons)) - (-> (const prop)) - (comp val e)))) - (else - (error "bad prop-val pair" x)))) - args))) + `(call ,(@implv new-object) + ,@(map (lambda (x) + (pmatch x + ((,prop ,val) + (-> (call (-> (primitive 'cons)) + (-> (const prop)) + (comp val e)))) + (else + (error "bad prop-val pair" x)))) + args))) ((pref ,obj ,prop) (@impl pget (comp obj e) diff --cc module/language/tree-il/effects.scm index c393264aa,4610f7f8f..8b380da27 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@@ -265,12 -263,39 +265,33 @@@ of an expression. (cause &zero-values)) ;; Effect-free primitives. - (($ _ (and name (? effect+exception-free-primitive?)) args) - (logior (accumulate-effects args) - (if (constructor-primitive? name) - (cause &allocation) - &no-effects))) - (($ _ - ($ _ (or 'values 'eq? 'eqv? 'equal?)) - args) ++ (($ _ (or 'values 'eq? 'eqv? 'equal?) args) + (accumulate-effects args)) + - (($ _ - ($ _ (or 'not 'pair? 'null? 'list? 'symbol? - 'vector? 'struct? 'string? 'number? - 'char?)) ++ (($ _ (or 'not 'pair? 'null? 'list? 'symbol? ++ 'vector? 'struct? 'string? 'number? ++ 'char?) + (arg)) + (compute-effects arg)) + + ;; Primitives that allocate memory. - (($ _ ($ _ 'cons) (x y)) ++ (($ _ 'cons (x y)) + (logior (compute-effects x) (compute-effects y) + &allocation)) + - (($ _ ($ _ (or 'list 'vector)) args) ++ (($ _ (or 'list 'vector) args) + (logior (accumulate-effects args) &allocation)) + - (($ _ ($ _ 'make-prompt-tag) ()) ++ (($ _ 'make-prompt-tag ()) + &allocation) + - (($ _ ($ _ 'make-prompt-tag) (arg)) ++ (($ _ 'make-prompt-tag (arg)) + (logior (compute-effects arg) &allocation)) + + ;; Primitives that are normally effect-free, but which might + ;; cause type checks, allocate memory, or access mutable + ;; memory. FIXME: expand, to be more precise. - (($ _ - ($ _ (and name - (? effect-free-primitive?))) - args) + (($ _ (and name (? effect-free-primitive?)) args) (logior (accumulate-effects args) (cause &type-check) (if (constructor-primitive? name) diff --cc module/language/tree-il/fix-letrec.scm index cf6e381ca,60c87e389..b5722fe09 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@@ -38,17 -38,17 +38,16 @@@ (( gensym) (not (memq gensym bound-vars))) (( test consequent alternate) - (and (simple-expression? test bound-vars simple-primitive?) - (simple-expression? consequent bound-vars simple-primitive?) - (simple-expression? alternate bound-vars simple-primitive?))) + (and (simple-expression? test bound-vars simple-primcall?) + (simple-expression? consequent bound-vars simple-primcall?) + (simple-expression? alternate bound-vars simple-primcall?))) - (( exps) - (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?)) - exps)) - (( proc args) - (and (primitive-ref? proc) - (simple-primcall? x) + (( head tail) - (and (simple-expression? head bound-vars simple-primitive?) - (simple-expression? tail bound-vars simple-primitive?))) ++ (and (simple-expression? head bound-vars simple-primcall?) ++ (simple-expression? tail bound-vars simple-primcall?))) + (( name args) - (and (simple-primitive? name) - ;; FIXME: check arity? ++ (and (simple-primcall? x) (and-map (lambda (x) - (simple-expression? x bound-vars simple-primitive?)) + (simple-expression? x bound-vars simple-primcall?)) args))) (else #f))) diff --cc module/language/tree-il/peval.scm index 542ded164,81921e363..041d99d7c --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@@ -806,9 -827,9 +816,9 @@@ top-level bindings from ENV and return (let ((exp (for-effect exp))) (if (void? exp) exp - (make-sequence src (list exp (make-void #f))))) + (make-seq src exp (make-void #f)))) (begin - (set-operand-residualize?! op #t) + (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) (($ src names gensyms vals body) (define (compute-alias exp) @@@ -1088,115 -1102,20 +1098,126 @@@ ((value test effect) #t) (else (null? (cdr vals)))) (every singly-valued-expression? vals)) - (for-tail (make-sequence src (append (cdr vals) (list (car vals))))) - (make-application src (make-primitive-ref #f 'values) vals)))))) - (($ src (and apply ($ _ (or 'apply '@apply))) - (proc args ... tail)) + (for-tail (list->seq src (append (cdr vals) (list (car vals))))) + (make-primcall src 'values vals)))))) + ++ (($ src (or 'apply '@apply) (proc args ... tail)) + (match (for-value tail) + (($ _ (args* ...)) + (let ((args* (map (lambda (x) (make-const #f x)) args*))) - (for-tail (make-application src proc (append args args*))))) - (($ _ ($ _ 'list) args*) - (for-tail (make-application src proc (append args args*)))) ++ (for-tail (make-call src proc (append args args*))))) ++ (($ _ 'list args*) ++ (for-tail (make-call src proc (append args args*)))) + (tail + (let ((args (append (map for-value args) (list tail)))) - (make-application src apply (cons (for-value proc) args)))))) - (($ src orig-proc orig-args) ++ (make-primcall src '@apply (cons (for-value proc) args)))))) ++ + (($ src (? constructor-primitive? name) args) + (cond + ((and (memq ctx '(effect test)) + (match (cons name args) + ((or ('cons _ _) + ('list . _) + ('vector . _) + ('make-prompt-tag) + ('make-prompt-tag ($ _ (? string?)))) + #t) + (_ #f))) + ;; Some expressions can be folded without visiting the + ;; arguments for value. + (let ((res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (for-tail (list->seq src (append args (list res)))))) + (else + (match (cons name (map for-value args)) + (('cons x ($ _ (? (cut eq? <> '())))) + (make-primcall src 'list (list x))) + (('cons x ($ _ 'list elts)) + (make-primcall src 'list (cons x elts))) + ((name . args) + (make-primcall src name args)))))) + + (($ src (? accessor-primitive? name) args) + (match (cons name (map for-value args)) + ;; FIXME: these for-tail recursions could take place outside + ;; an effort counter. + (('car ($ src 'cons (head tail))) + (for-tail (make-seq src tail head))) + (('cdr ($ src 'cons (head tail))) + (for-tail (make-seq src head tail))) + (('car ($ src 'list (head . tail))) + (for-tail (list->seq src (append tail (list head))))) + (('cdr ($ src 'list (head . tail))) + (for-tail (make-seq src head (make-primcall #f 'list tail)))) + + (('car ($ src (head . tail))) + (for-tail (make-const src head))) + (('cdr ($ src (head . tail))) + (for-tail (make-const src tail))) + (((or 'memq 'memv) k ($ _ (elts ...))) + ;; FIXME: factor + (case ctx + ((effect) + (for-tail + (make-seq src k (make-void #f)))) + ((test) + (cond + ((const? k) + ;; A shortcut. The `else' case would handle it, but + ;; this way is faster. + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (and (member (const-exp k) elts) #t)))) + ((null? elts) + (for-tail + (make-seq src k (make-const #f #f)))) + (else + (let ((t (gensym "t ")) + (eq (if (eq? name 'memq) 'eq? 'eqv?))) + (record-new-temporary! 't t (length elts)) + (for-tail + (make-let + src (list 't) (list t) (list k) + (let lp ((elts elts)) + (define test + (make-primcall #f eq + (list (make-lexical-ref #f 't t) + (make-const #f (car elts))))) + (if (null? (cdr elts)) + test + (make-conditional src test + (make-const #f #t) + (lp (cdr elts))))))))))) + (else + (cond + ((const? k) + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (member (const-exp k) elts)))) + ((null? elts) + (for-tail (make-seq src k (make-const #f #f)))) + (else + (make-primcall src name (list k (make-const #f elts)))))))) + ((name . args) + (fold-constants src name args ctx)))) + + (($ src (? equality-primitive? name) (a b)) + (let ((val-a (for-value a)) + (val-b (for-value b))) + (log 'equality-primitive name val-a val-b) + (cond ((and (lexical-ref? val-a) (lexical-ref? val-b) + (eq? (lexical-ref-gensym val-a) + (lexical-ref-gensym val-b))) + (for-tail (make-const #f #t))) + (else + (fold-constants src name (list val-a val-b) ctx))))) + + (($ src (? effect-free-primitive? name) args) + (fold-constants src name (map for-value args) ctx)) + + (($ src name args) + (make-primcall src name (map for-value args))) + + (($ src orig-proc orig-args) ;; todo: augment the global env with specialized functions (let ((proc (visit orig-proc 'operator))) (match proc @@@ -1327,36 -1348,99 +1348,91 @@@ new body (and alt (for-tail alt)))))) - (($ src exps) - (let lp ((exps exps) (effects '())) - (match exps - ((last) - (if (null? effects) - (for-tail last) - (make-sequence - src - (reverse (cons (for-tail last) effects))))) - ((head . rest) - (let ((head (for-effect head))) - (cond - ((sequence? head) - (lp (append (sequence-exps head) rest) effects)) - ((void? head) - (lp rest effects)) - (else - (lp rest (cons head effects))))))))) + (($ src head tail) + (let ((head (for-effect head)) + (tail (for-tail tail))) + (if (void? head) + tail + (make-seq src + (if (and (seq? head) + (void? (seq-tail head))) + (seq-head head) + head) + tail)))) (($ src tag body handler) - (define (singly-used-definition x) + (define (make-prompt-tag? x) + (match x - (($ _ ($ _ 'make-prompt-tag) - (or () ((? constant-expression?)))) ++ (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) + #t) + (_ #f))) + (define (find-definition x n-aliases) (cond - ((and (lexical-ref? x) - ;; Only fetch definitions with single uses. - (= (lexical-refcount (lexical-ref-gensym x)) 1) - (lookup (lexical-ref-gensym x))) - => (lambda (x) - (singly-used-definition (visit-operand x counter 'value 10 10)))) - (else x))) - (match (singly-used-definition tag) - (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) - ;; There is no way that an could know the tag - ;; for this , so we can elide the - ;; entirely. - (for-tail body)) - (_ - (make-prompt src (for-value tag) (for-tail body) - (for-value handler))))) + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f)))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + + (let ((tag (for-value tag)) + (body (for-tail body))) + (cond + ((find-definition tag 1) + (lambda (val op) + (make-prompt-tag? val)) + => (lambda (val op) + ;; There is no way that an could know the tag + ;; for this , so we can elide the + ;; entirely. + (unrecord-operand-uses op 1) + body)) + ((find-definition tag 2) + (lambda (val op) + (and (make-prompt-tag? val) + (abort? body) + (tree-il=? (abort-tag body) tag))) + => (lambda (val op) + ;; (let ((t (make-prompt-tag))) + ;; (call-with-prompt t + ;; (lambda () (abort-to-prompt t val ...)) + ;; (lambda (k arg ...) e ...))) + ;; => (let-values (((k arg ...) (values values val ...))) + ;; e ...) + (unrecord-operand-uses op 2) + (for-tail + (make-let-values + src - (make-application #f (make-primitive-ref #f 'apply) - `(,(make-primitive-ref #f 'values) - ,(make-primitive-ref #f 'values) - ,@(abort-args body) - ,(abort-tail body))) ++ (make-primcall #f 'apply ++ `(,(make-primitive-ref #f 'values) ++ ,(make-primitive-ref #f 'values) ++ ,@(abort-args body) ++ ,(abort-tail body))) + (for-value handler))))) + (else + (make-prompt src tag body (for-value handler)))))) (($ src tag args tail) (make-abort src (for-value tag) (map for-value args) (for-value tail)))))) diff --cc test-suite/tests/cse.test index 154cc0614,523635fc7..b356852c1 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@@ -277,8 -282,14 +277,14 @@@ 'two)) ;; Actually this one should reduce in other ways, but this is the ;; current reduction: - (begin - (apply (primitive car) (toplevel x)) - (if (apply (primitive car) (toplevel x)) + (seq + (primcall car (toplevel x)) + (if (primcall car (toplevel x)) (const one) - (const two))))) + (const two)))) + + (pass-if-cse + (begin (cons 1 2 3) 4) - (begin - (apply (primitive cons) (const 1) (const 2) (const 3)) ++ (seq ++ (primcall cons (const 1) (const 2) (const 3)) + (const 4)))) diff --cc test-suite/tests/peval.test index 5efcc087d,7fae423bd..f3f3b41e3 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@@ -32,8 -32,11 +32,8 @@@ (@@ (language tree-il optimize) peval)) (define-syntax pass-if-peval -- (syntax-rules (resolve-primitives) ++ (syntax-rules () ((_ in pat) - (pass-if-peval in pat - (compile 'in #:from 'scheme #:to 'tree-il))) - ((_ resolve-primitives in pat) (pass-if-peval in pat (expand-primitives! (resolve-primitives! @@@ -966,28 -951,35 +966,33 @@@ (const 1) (lambda-case ((() #f args #f () (_)) - (apply (primitive @apply) - (lexical handler _) - (lexical args _))))))) + (primcall @apply + (lexical handler _) + (lexical args _))))))) (pass-if-peval - resolve-primitives ;; `while' without `break' or `continue' has no prompts and gets its ;; condition folded. Unfortunately the outer `lp' does not yet get - ;; elided. + ;; elided, and the continuation tag stays around. (The continue tag + ;; stays around because although it is not referenced, recursively + ;; visiting the loop in the continue handler manages to visit the tag + ;; twice before aborting. The abort doesn't unroll the recursive + ;; reference.) (while #t #t) - (letrec (lp) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (letrec (loop) (_) - ((lambda _ - (lambda-case - ((() #f #f #f () ()) - (call (lexical loop _)))))) - (call (lexical loop _))))))) - (call (lexical lp _)))) - (let (_) (_) ((apply (primitive make-prompt-tag) . _)) ++ (let (_) (_) ((primcall make-prompt-tag . _)) + (letrec (lp) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) + (letrec (loop) (_) + ((lambda _ + (lambda-case + ((() #f #f #f () ()) - (apply (lexical loop _)))))) - (apply (lexical loop _))))))) - (apply (lexical lp _))))) ++ (call (lexical loop _)))))) ++ (call (lexical loop _))))))) ++ (call (lexical lp _))))) (pass-if-peval - resolve-primitives (lambda (a . rest) (apply (lambda (x y) (+ x y)) a rest)) @@@ -1055,17 -1047,32 +1060,32 @@@ (let (failure) (_) ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (toplevel qux) (toplevel x)))))) - (if (apply (primitive struct?) (toplevel x)) - (if (apply (primitive eq?) - (apply (primitive struct-vtable) (toplevel x)) - (toplevel A)) + (call (toplevel qux) (toplevel x)))))) + (if (primcall struct? (toplevel x)) + (if (primcall eq? + (primcall struct-vtable (toplevel x)) + (toplevel A)) (if (toplevel B) - (apply (toplevel foo) (toplevel x)) + (call (toplevel foo) (toplevel x)) (if (toplevel C) - (apply (toplevel bar) (toplevel x)) + (call (toplevel bar) (toplevel x)) (if (toplevel D) - (apply (toplevel baz) (toplevel x)) - (apply (lexical failure _))))) - (apply (lexical failure _))) - (apply (lexical failure _))))) + (call (toplevel baz) (toplevel x)) + (call (lexical failure _))))) + (call (lexical failure _))) - (call (lexical failure _)))))) ++ (call (lexical failure _))))) + - (pass-if-peval resolve-primitives ++ (pass-if-peval + (apply (lambda (x y) (cons x y)) '(1 2)) - (apply (primitive cons) (const 1) (const 2))) ++ (primcall cons (const 1) (const 2))) + - (pass-if-peval resolve-primitives ++ (pass-if-peval + (apply (lambda (x y) (cons x y)) (list 1 2)) - (apply (primitive cons) (const 1) (const 2))) ++ (primcall cons (const 1) (const 2))) + - (pass-if-peval resolve-primitives ++ (pass-if-peval + (let ((t (make-prompt-tag))) + (call-with-prompt t + (lambda () (abort-to-prompt t 1 2 3)) + (lambda (k x y z) (list x y z)))) - (apply (primitive 'list) (const 1) (const 2) (const 3)))) ++ (primcall list (const 1) (const 2) (const 3))))