diff options
Diffstat (limited to 'libguile/hash.c')
-rw-r--r-- | libguile/hash.c | 376 |
1 files changed, 206 insertions, 170 deletions
diff --git a/libguile/hash.c b/libguile/hash.c index a79f03d95..d47c7e054 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -45,232 +45,271 @@ 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) { - /* from suggestion at: */ - /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */ - - unsigned long h = 0; - while (len-- > 0) - h = *str++ + h*37; - return h; + return narrow_string_hash (str, len); } unsigned long scm_i_string_hash (SCM str) { size_t len = scm_i_string_length (str); - size_t i = 0; - unsigned long h = 0; - while (len-- > 0) - h = (unsigned long) scm_i_string_ref (str, i++) + h * 37; - - scm_remember_upto_here_1 (str); - return h; + 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) { -#ifdef HAVE_WCHAR_H - mbstate_t state; - wchar_t c; - size_t byte_idx = 0, nbytes; - unsigned long h = 0; - - if (len == (size_t) -1) - len = strlen (str); - - while ((nbytes = mbrtowc (&c, str + byte_idx, len - byte_idx, &state)) > 0) - { - if (nbytes >= (size_t) -2) - /* Invalid input string; punt. */ - return scm_i_string_hash (scm_from_locale_stringn (str, len)); - - h = (unsigned long) c + h * 37; - byte_idx += nbytes; - } - - return h; -#else return scm_i_string_hash (scm_from_locale_stringn (str, len)); -#endif } unsigned long scm_i_latin1_string_hash (const char *str, size_t len) { - const scm_t_uint8 *ustr = (const scm_t_uint8 *) str; - size_t i = 0; - unsigned long h = 0; - if (len == (size_t) -1) len = strlen (str); - for (; i < len; i++) - h = (unsigned long) ustr[i] + h * 37; - - return h; + 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 *ustr = (const scm_t_uint8 *) str; - size_t byte_idx = 0; - unsigned long h = 0; - + 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); - while (byte_idx < len) + 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) { - ucs4_t c; - int nbytes; - - nbytes = u8_mbtouc (&c, ustr + byte_idx, len - byte_idx); - if (nbytes == 0) - break; - else if (nbytes < 0) - /* Bad UTF-8; punt. */ - return scm_i_string_hash (scm_from_utf8_stringn (str, len)); - - h = (unsigned long) c + h * 37; - byte_idx += nbytes; + 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; } - return h; -} + /* 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); -/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */ -/* Dirk:FIXME:: scm_hasher could be made static. */ + 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; +} -unsigned long -scm_hasher(SCM obj, unsigned long n, size_t d) +/* Thomas Wang's integer hasher, from + http://www.cris.com/~Ttwang/tech/inthash.htm. */ +static unsigned long +scm_raw_ihashq (scm_t_bits key) { - switch (SCM_ITAG3 (obj)) { - case scm_tc3_int_1: - case scm_tc3_int_2: - return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */ - case scm_tc3_imm24: - if (SCM_CHARP(obj)) - return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n; - switch (SCM_UNPACK (obj)) { - case SCM_EOL_BITS: - d = 256; - break; - case SCM_BOOL_T_BITS: - d = 257; - break; - case SCM_BOOL_F_BITS: - d = 258; - break; - case SCM_EOF_VAL_BITS: - d = 259; - break; - default: - d = 263; /* perhaps should be error */ + if (sizeof (key) < 8) + { + key = (key ^ 61) ^ (key >> 16); + key = key + (key << 3); + key = key ^ (key >> 4); + key = key * 0x27d4eb2d; + key = key ^ (key >> 15); } - return d % n; - default: - return 263 % n; /* perhaps should be error */ - case scm_tc3_cons: - switch SCM_TYP7(obj) { - default: - return 263 % n; + 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_TYP7(obj)) + { + /* FIXME: do better for structs, variables, ... Also the hashes + are currently associative, which ain't the right thing. */ case scm_tc7_smob: - return 263 % n; + return scm_raw_ihashq (SCM_TYP16 (obj)); case scm_tc7_number: - switch SCM_TYP16 (obj) { - case scm_tc16_big: - return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n))); - case scm_tc16_real: - { - double r = SCM_REAL_VALUE (obj); - if (floor (r) == r && !isinf (r) && !isnan (r)) - { - obj = scm_inexact_to_exact (obj); - return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n))); - } - } - /* Fall through */ - case scm_tc16_complex: - case scm_tc16_fraction: - obj = scm_number_to_string (obj, scm_from_int (10)); - /* Fall through */ - } - /* Fall through */ + 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: - { - unsigned long hash = - scm_i_string_hash (obj) % n; - return hash; - } + return scm_i_string_hash (obj); case scm_tc7_symbol: - return scm_i_symbol_hash (obj) % n; + return scm_i_symbol_hash (obj); case scm_tc7_pointer: - { - /* Pointer objects are typically used to store addresses of heap - objects. On most platforms, these are at least 3-byte - aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned - addresses), so get rid of the least significant bits. */ - scm_t_uintptr significant_bits; - - significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL; - return (size_t) significant_bits % n; - } + 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); - if (len > 5) - { - size_t i = d/2; - unsigned long h = 1; - while (i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len); - h = ((h << 8) + (scm_hasher (elt, n, 2))) % n; - } - return h; - } - else - { - size_t i = len; - unsigned long h = (n)-1; - while (i--) - { - SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len); - h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n; - } - return h; - } + 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; } case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: - if (d) return (scm_hasher (SCM_CAR (obj), n, d/2) - + scm_hasher (SCM_CDR (obj), n, d/2)) % n; - else return 1; - case scm_tc7_port: - return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n; - case scm_tc7_program: - return 262 % n; + 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); + default: + return scm_raw_ihashq (SCM_CELL_WORD_0 (obj)); } - } } - unsigned long scm_ihashq (SCM obj, unsigned long n) { - return (SCM_UNPACK (obj) >> 1) % n; + return scm_raw_ihashq (SCM_UNPACK (obj)) % n; } @@ -300,13 +339,10 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, unsigned long scm_ihashv (SCM obj, unsigned long n) { - if (SCM_CHARP(obj)) - return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */ - if (SCM_NUMP(obj)) - return (unsigned long) scm_hasher(obj, n, 10); + return scm_raw_ihash (obj, 10) % n; else - return SCM_UNPACK (obj) % n; + return scm_raw_ihashq (SCM_UNPACK (obj)) % n; } @@ -336,7 +372,7 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, unsigned long scm_ihash (SCM obj, unsigned long n) { - return (unsigned long) scm_hasher (obj, n, 10); + return (unsigned long) scm_raw_ihash (obj, 10) % n; } SCM_DEFINE (scm_hash, "hash", 2, 0, 0, |