mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
b071ce2147
Currently failing some guardian tests. * libguile/tags.h: Refactor tagging so that tc3 bits for a pair live in the SCM value, not in the heap words. Do the same for structs. This more rational tagging strategy will make native code generation easier. Note that this means that to check a heap pointer for its type, you first have to ensure that it has the expected tc3, as not all the type bits are on the heap. (SCM_TYP3): Check the SCM tag type, not the bits in the cell. (SCM_HAS_TYP3): New helper. (SCM_I_CONSP): Redefine to just check the typ3. (scm_tcs_cons_imcar, scm_tcs_cons_nimcar, scm_tcs_struct): Remove, as they are no longer necessary. * libguile/array-handle.c (scm_i_array_implementation_for_obj): Check for heap objects before checking type bits, so we don't check pairs. * libguile/evalext.c (scm_self_evaluating_p): * libguile/gc.c (scm_i_tag_name): * libguile/goops.c (scm_class_of) * libguile/hash.c (scm_hasher): * libguile/print.c (iprin1): Adapt to tagging changes. * libguile/gc.c (scm_storage_prehistory): Register all displacements here. There are the same displacements as before, unfortunately. * libguile/list.c (SCM_I_CONS): * libguile/pairs.c (scm_cons): * libguile/pairs.h (scm_is_pair): * libguile/vm-engine.h (CONS): Tag pairs with scm_tc3_pair. * libguile/modules.c (scm_post_boot_init_modules): * libguile/modules.h (SCM_MODULEP): * libguile/struct.c (struct_finalizer_trampoline, scm_i_alloc_struct): (scm_make_vtable_vtable): * libguile/struct.h (SCM_STRUCTP, SCM_STRUCT_VTABLE_DATA): (SCM_STRUCT_VTABLE_SLOTS): * libguile/vm-i-scheme.c (make-struct): Adapt to struct tagging changes. * libguile/numbers.h (SCM_I_INUMP): * module/rnrs/arithmetic/fixnums.scm (fixnum?, inline-fixnum?): Adapt to the new fixnum tag. * libguile/numbers.h (SCM_INEXACTP): Make sure of the tc3 before looking at the cell type.
463 lines
14 KiB
C
463 lines
14 KiB
C
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
|
||
* 2009, 2010, 2011, 2012, 2013 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 <config.h>
|
||
#endif
|
||
|
||
#ifdef HAVE_WCHAR_H
|
||
#include <wchar.h>
|
||
#endif
|
||
|
||
#include <math.h>
|
||
#include <unistr.h>
|
||
|
||
#include "libguile/_scm.h"
|
||
#include "libguile/chars.h"
|
||
#include "libguile/ports.h"
|
||
#include "libguile/strings.h"
|
||
#include "libguile/symbols.h"
|
||
#include "libguile/vectors.h"
|
||
|
||
#include "libguile/validate.h"
|
||
#include "libguile/hash.h"
|
||
|
||
|
||
#ifndef floor
|
||
extern double floor();
|
||
#endif
|
||
|
||
|
||
/* This hash function is originally from
|
||
http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
|
||
Public Domain. No warranty. */
|
||
|
||
#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))
|
||
#define mix(a,b,c) \
|
||
{ \
|
||
a -= c; a ^= rot(c, 4); c += b; \
|
||
b -= a; b ^= rot(a, 6); a += c; \
|
||
c -= b; c ^= rot(b, 8); b += a; \
|
||
a -= c; a ^= rot(c,16); c += b; \
|
||
b -= a; b ^= rot(a,19); a += c; \
|
||
c -= b; c ^= rot(b, 4); b += a; \
|
||
}
|
||
|
||
#define final(a,b,c) \
|
||
{ \
|
||
c ^= b; c -= rot(b,14); \
|
||
a ^= c; a -= rot(c,11); \
|
||
b ^= a; b -= rot(a,25); \
|
||
c ^= b; c -= rot(b,16); \
|
||
a ^= c; a -= rot(c,4); \
|
||
b ^= a; b -= rot(a,14); \
|
||
c ^= b; c -= rot(b,24); \
|
||
}
|
||
|
||
#define JENKINS_LOOKUP3_HASHWORD2(k, length, ret) \
|
||
do { \
|
||
scm_t_uint32 a, b, c; \
|
||
\
|
||
/* Set up the internal state. */ \
|
||
a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47; \
|
||
\
|
||
/* Handle most of the key. */ \
|
||
while (length > 3) \
|
||
{ \
|
||
a += k[0]; \
|
||
b += k[1]; \
|
||
c += k[2]; \
|
||
mix (a, b, c); \
|
||
length -= 3; \
|
||
k += 3; \
|
||
} \
|
||
\
|
||
/* Handle the last 3 elements. */ \
|
||
switch(length) /* All the case statements fall through. */ \
|
||
{ \
|
||
case 3 : c += k[2]; \
|
||
case 2 : b += k[1]; \
|
||
case 1 : a += k[0]; \
|
||
final (a, b, c); \
|
||
case 0: /* case 0: nothing left to add */ \
|
||
break; \
|
||
} \
|
||
\
|
||
if (sizeof (ret) == 8) \
|
||
ret = (((unsigned long) c) << 32) | b; \
|
||
else \
|
||
ret = c; \
|
||
} while (0)
|
||
|
||
|
||
static unsigned long
|
||
narrow_string_hash (const scm_t_uint8 *str, size_t len)
|
||
{
|
||
unsigned long ret;
|
||
JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
|
||
ret >>= 2; /* Ensure that it fits in a fixnum. */
|
||
return ret;
|
||
}
|
||
|
||
static unsigned long
|
||
wide_string_hash (const scm_t_wchar *str, size_t len)
|
||
{
|
||
unsigned long ret;
|
||
JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
|
||
ret >>= 2; /* Ensure that it fits in a fixnum. */
|
||
return ret;
|
||
}
|
||
|
||
unsigned long
|
||
scm_string_hash (const unsigned char *str, size_t len)
|
||
{
|
||
return narrow_string_hash (str, len);
|
||
}
|
||
|
||
unsigned long
|
||
scm_i_string_hash (SCM str)
|
||
{
|
||
size_t len = scm_i_string_length (str);
|
||
|
||
if (scm_i_is_narrow_string (str))
|
||
return narrow_string_hash ((const scm_t_uint8 *) scm_i_string_chars (str),
|
||
len);
|
||
else
|
||
return wide_string_hash (scm_i_string_wide_chars (str), len);
|
||
}
|
||
|
||
unsigned long
|
||
scm_i_locale_string_hash (const char *str, size_t len)
|
||
{
|
||
return scm_i_string_hash (scm_from_locale_stringn (str, len));
|
||
}
|
||
|
||
unsigned long
|
||
scm_i_latin1_string_hash (const char *str, size_t len)
|
||
{
|
||
if (len == (size_t) -1)
|
||
len = strlen (str);
|
||
|
||
return narrow_string_hash ((const scm_t_uint8 *) str, len);
|
||
}
|
||
|
||
/* A tricky optimization, but probably worth it. */
|
||
unsigned long
|
||
scm_i_utf8_string_hash (const char *str, size_t len)
|
||
{
|
||
const scm_t_uint8 *end, *ustr = (const scm_t_uint8 *) str;
|
||
unsigned long ret;
|
||
|
||
/* The length of the string in characters. This name corresponds to
|
||
Jenkins' original name. */
|
||
size_t length;
|
||
|
||
scm_t_uint32 a, b, c, u32;
|
||
|
||
if (len == (size_t) -1)
|
||
len = strlen (str);
|
||
|
||
end = ustr + len;
|
||
|
||
if (u8_check (ustr, len) != NULL)
|
||
/* Invalid UTF-8; punt. */
|
||
return scm_i_string_hash (scm_from_utf8_stringn (str, len));
|
||
|
||
length = u8_strnlen (ustr, len);
|
||
|
||
/* Set up the internal state. */
|
||
a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47;
|
||
|
||
/* Handle most of the key. */
|
||
while (length > 3)
|
||
{
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
a += u32;
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
b += u32;
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
c += u32;
|
||
mix (a, b, c);
|
||
length -= 3;
|
||
}
|
||
|
||
/* Handle the last 3 elements's. */
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
a += u32;
|
||
if (--length)
|
||
{
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
b += u32;
|
||
if (--length)
|
||
{
|
||
ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
|
||
c += u32;
|
||
}
|
||
}
|
||
|
||
final (a, b, c);
|
||
|
||
if (sizeof (unsigned long) == 8)
|
||
ret = (((unsigned long) c) << 32) | b;
|
||
else
|
||
ret = c;
|
||
|
||
ret >>= 2; /* Ensure that it fits in a fixnum. */
|
||
return ret;
|
||
}
|
||
|
||
static unsigned long scm_raw_ihashq (scm_t_bits key);
|
||
static unsigned long scm_raw_ihash (SCM obj, size_t depth);
|
||
|
||
/* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
|
||
result, unless DEPTH is zero. Assumes that OBJ is a struct. */
|
||
static unsigned long
|
||
scm_i_struct_hash (SCM obj, size_t depth)
|
||
{
|
||
SCM layout;
|
||
scm_t_bits *data;
|
||
size_t struct_size, field_num;
|
||
unsigned long hash;
|
||
|
||
layout = SCM_STRUCT_LAYOUT (obj);
|
||
struct_size = scm_i_symbol_length (layout) / 2;
|
||
data = SCM_STRUCT_DATA (obj);
|
||
|
||
hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
|
||
if (depth > 0)
|
||
for (field_num = 0; field_num < struct_size; field_num++)
|
||
{
|
||
int protection;
|
||
|
||
protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
|
||
if (protection != 'h' && protection != 'o')
|
||
{
|
||
int type;
|
||
type = scm_i_symbol_ref (layout, field_num * 2);
|
||
switch (type)
|
||
{
|
||
case 'p':
|
||
hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
|
||
depth / 2);
|
||
break;
|
||
case 'u':
|
||
hash ^= scm_raw_ihashq (data[field_num]);
|
||
break;
|
||
default:
|
||
/* Ignore 's' fields. */;
|
||
}
|
||
}
|
||
}
|
||
|
||
/* FIXME: Tail elements should be taken into account. */
|
||
|
||
return hash;
|
||
}
|
||
|
||
/* Thomas Wang's integer hasher, from
|
||
http://www.cris.com/~Ttwang/tech/inthash.htm. */
|
||
static unsigned long
|
||
scm_raw_ihashq (scm_t_bits key)
|
||
{
|
||
if (sizeof (key) < 8)
|
||
{
|
||
key = (key ^ 61) ^ (key >> 16);
|
||
key = key + (key << 3);
|
||
key = key ^ (key >> 4);
|
||
key = key * 0x27d4eb2d;
|
||
key = key ^ (key >> 15);
|
||
}
|
||
else
|
||
{
|
||
key = (~key) + (key << 21); // key = (key << 21) - key - 1;
|
||
key = key ^ (key >> 24);
|
||
key = (key + (key << 3)) + (key << 8); // key * 265
|
||
key = key ^ (key >> 14);
|
||
key = (key + (key << 2)) + (key << 4); // key * 21
|
||
key = key ^ (key >> 28);
|
||
key = key + (key << 31);
|
||
}
|
||
key >>= 2; /* Ensure that it fits in a fixnum. */
|
||
return key;
|
||
}
|
||
|
||
/* `depth' is used to limit recursion. */
|
||
static unsigned long
|
||
scm_raw_ihash (SCM obj, size_t depth)
|
||
{
|
||
if (SCM_IMP (obj))
|
||
return scm_raw_ihashq (SCM_UNPACK (obj));
|
||
|
||
switch (SCM_TYP3 (obj))
|
||
{
|
||
case scm_tc3_cons:
|
||
if (depth)
|
||
return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
|
||
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
|
||
else
|
||
return scm_raw_ihashq (scm_tc3_cons);
|
||
|
||
case scm_tc3_struct:
|
||
return scm_i_struct_hash (obj, depth);
|
||
|
||
case scm_tc3_heap:
|
||
switch SCM_TYP7(obj)
|
||
{
|
||
case scm_tc7_smob:
|
||
return scm_raw_ihashq (SCM_TYP16 (obj));
|
||
case scm_tc7_number:
|
||
if (scm_is_integer (obj))
|
||
{
|
||
SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
|
||
if (scm_is_inexact (obj))
|
||
obj = scm_inexact_to_exact (obj);
|
||
return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
|
||
}
|
||
else
|
||
return scm_i_string_hash (scm_number_to_string (obj,
|
||
scm_from_int (10)));
|
||
case scm_tc7_string:
|
||
return scm_i_string_hash (obj);
|
||
case scm_tc7_symbol:
|
||
return scm_i_symbol_hash (obj);
|
||
case scm_tc7_pointer:
|
||
return scm_raw_ihashq ((scm_t_uintptr) SCM_POINTER_VALUE (obj));
|
||
case scm_tc7_wvect:
|
||
case scm_tc7_vector:
|
||
{
|
||
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
|
||
size_t i = depth / 2;
|
||
unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
|
||
if (len)
|
||
while (i--)
|
||
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
|
||
return h;
|
||
}
|
||
default:
|
||
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
|
||
}
|
||
|
||
default:
|
||
/* Invalid object. */
|
||
abort ();
|
||
}
|
||
}
|
||
|
||
|
||
|
||
unsigned long
|
||
scm_ihashq (SCM obj, unsigned long n)
|
||
{
|
||
return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
|
||
}
|
||
|
||
|
||
SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
|
||
(SCM key, SCM size),
|
||
"Determine a hash value for @var{key} that is suitable for\n"
|
||
"lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
|
||
"used as the equality predicate. The function returns an\n"
|
||
"integer in the range 0 to @var{size} - 1. Note that\n"
|
||
"@code{hashq} may use internal addresses. Thus two calls to\n"
|
||
"hashq where the keys are @code{eq?} are not guaranteed to\n"
|
||
"deliver the same value if the key object gets garbage collected\n"
|
||
"in between. This can happen, for example with symbols:\n"
|
||
"@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
|
||
"different values, since @code{foo} will be garbage collected.")
|
||
#define FUNC_NAME s_scm_hashq
|
||
{
|
||
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
|
||
return scm_from_ulong (scm_ihashq (key, sz));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
|
||
unsigned long
|
||
scm_ihashv (SCM obj, unsigned long n)
|
||
{
|
||
if (SCM_NUMP(obj))
|
||
return scm_raw_ihash (obj, 10) % n;
|
||
else
|
||
return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
|
||
}
|
||
|
||
|
||
SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
|
||
(SCM key, SCM size),
|
||
"Determine a hash value for @var{key} that is suitable for\n"
|
||
"lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
|
||
"used as the equality predicate. The function returns an\n"
|
||
"integer in the range 0 to @var{size} - 1. Note that\n"
|
||
"@code{(hashv key)} may use internal addresses. Thus two calls\n"
|
||
"to hashv where the keys are @code{eqv?} are not guaranteed to\n"
|
||
"deliver the same value if the key object gets garbage collected\n"
|
||
"in between. This can happen, for example with symbols:\n"
|
||
"@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
|
||
"different values, since @code{foo} will be garbage collected.")
|
||
#define FUNC_NAME s_scm_hashv
|
||
{
|
||
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
|
||
return scm_from_ulong (scm_ihashv (key, sz));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
|
||
unsigned long
|
||
scm_ihash (SCM obj, unsigned long n)
|
||
{
|
||
return (unsigned long) scm_raw_ihash (obj, 10) % n;
|
||
}
|
||
|
||
SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
|
||
(SCM key, SCM size),
|
||
"Determine a hash value for @var{key} that is suitable for\n"
|
||
"lookups in a hashtable of size @var{size}, where @code{equal?}\n"
|
||
"is used as the equality predicate. The function returns an\n"
|
||
"integer in the range 0 to @var{size} - 1.")
|
||
#define FUNC_NAME s_scm_hash
|
||
{
|
||
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
|
||
return scm_from_ulong (scm_ihash (key, sz));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
|
||
void
|
||
scm_init_hash ()
|
||
{
|
||
#include "libguile/hash.x"
|
||
}
|
||
|
||
|
||
/*
|
||
Local Variables:
|
||
c-file-style: "gnu"
|
||
End:
|
||
*/
|