1 /* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
2 * 2009, 2010, 2011, 2012, 2014, 2015 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
33 #include "libguile/_scm.h"
34 #include "libguile/chars.h"
35 #include "libguile/ports.h"
36 #include "libguile/strings.h"
37 #include "libguile/symbols.h"
38 #include "libguile/vectors.h"
40 #include "libguile/validate.h"
41 #include "libguile/hash.h"
45 extern double floor();
49 /* This hash function is originally from
50 http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
51 Public Domain. No warranty. */
53 #define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))
56 a -= c; a ^= rot(c, 4); c += b; \
57 b -= a; b ^= rot(a, 6); a += c; \
58 c -= b; c ^= rot(b, 8); b += a; \
59 a -= c; a ^= rot(c,16); c += b; \
60 b -= a; b ^= rot(a,19); a += c; \
61 c -= b; c ^= rot(b, 4); b += a; \
64 #define final(a,b,c) \
66 c ^= b; c -= rot(b,14); \
67 a ^= c; a -= rot(c,11); \
68 b ^= a; b -= rot(a,25); \
69 c ^= b; c -= rot(b,16); \
70 a ^= c; a -= rot(c,4); \
71 b ^= a; b -= rot(a,14); \
72 c ^= b; c -= rot(b,24); \
75 #define JENKINS_LOOKUP3_HASHWORD2(k, length, ret) \
77 scm_t_uint32 a, b, c; \
79 /* Set up the internal state. */ \
80 a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47; \
82 /* Handle most of the key. */ \
93 /* Handle the last 3 elements. */ \
94 switch(length) /* All the case statements fall through. */ \
100 case 0: /* case 0: nothing left to add */ \
104 if (sizeof (ret) == 8) \
105 ret = (((unsigned long) c) << 32) | b; \
112 narrow_string_hash (const scm_t_uint8
*str
, size_t len
)
115 JENKINS_LOOKUP3_HASHWORD2 (str
, len
, ret
);
116 ret
>>= 2; /* Ensure that it fits in a fixnum. */
121 wide_string_hash (const scm_t_wchar
*str
, size_t len
)
124 JENKINS_LOOKUP3_HASHWORD2 (str
, len
, ret
);
125 ret
>>= 2; /* Ensure that it fits in a fixnum. */
130 scm_i_string_hash (SCM str
)
132 size_t len
= scm_i_string_length (str
);
134 if (scm_i_is_narrow_string (str
))
135 return narrow_string_hash ((const scm_t_uint8
*) scm_i_string_chars (str
),
138 return wide_string_hash (scm_i_string_wide_chars (str
), len
);
142 scm_i_locale_string_hash (const char *str
, size_t len
)
144 return scm_i_string_hash (scm_from_locale_stringn (str
, len
));
148 scm_i_latin1_string_hash (const char *str
, size_t len
)
150 if (len
== (size_t) -1)
153 return narrow_string_hash ((const scm_t_uint8
*) str
, len
);
156 /* A tricky optimization, but probably worth it. */
158 scm_i_utf8_string_hash (const char *str
, size_t len
)
160 const scm_t_uint8
*end
, *ustr
= (const scm_t_uint8
*) str
;
163 /* The length of the string in characters. This name corresponds to
164 Jenkins' original name. */
167 scm_t_uint32 a
, b
, c
, u32
;
169 if (len
== (size_t) -1)
174 if (u8_check (ustr
, len
) != NULL
)
175 /* Invalid UTF-8; punt. */
176 return scm_i_string_hash (scm_from_utf8_stringn (str
, len
));
178 length
= u8_strnlen (ustr
, len
);
180 /* Set up the internal state. */
181 a
= b
= c
= 0xdeadbeef + ((scm_t_uint32
)(length
<<2)) + 47;
183 /* Handle most of the key. */
186 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
188 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
190 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
196 /* Handle the last 3 elements's. */
197 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
201 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
205 ustr
+= u8_mbtouc_unsafe (&u32
, ustr
, end
- ustr
);
212 if (sizeof (unsigned long) == 8)
213 ret
= (((unsigned long) c
) << 32) | b
;
217 ret
>>= 2; /* Ensure that it fits in a fixnum. */
221 static unsigned long scm_raw_ihashq (scm_t_bits key
);
222 static unsigned long scm_raw_ihash (SCM obj
, size_t depth
);
224 /* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
225 result, unless DEPTH is zero. Assumes that OBJ is a struct. */
227 scm_i_struct_hash (SCM obj
, size_t depth
)
231 size_t struct_size
, field_num
;
234 layout
= SCM_STRUCT_LAYOUT (obj
);
235 struct_size
= scm_i_symbol_length (layout
) / 2;
236 data
= SCM_STRUCT_DATA (obj
);
238 hash
= scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj
)));
240 for (field_num
= 0; field_num
< struct_size
; field_num
++)
244 protection
= scm_i_symbol_ref (layout
, field_num
* 2 + 1);
245 if (protection
!= 'h' && protection
!= 'o')
248 type
= scm_i_symbol_ref (layout
, field_num
* 2);
252 hash
^= scm_raw_ihash (SCM_PACK (data
[field_num
]),
256 hash
^= scm_raw_ihashq (data
[field_num
]);
259 /* Ignore 's' fields. */;
264 /* FIXME: Tail elements should be taken into account. */
269 /* Thomas Wang's integer hasher, from
270 http://www.cris.com/~Ttwang/tech/inthash.htm. */
272 scm_raw_ihashq (scm_t_bits key
)
274 if (sizeof (key
) < 8)
276 key
= (key
^ 61) ^ (key
>> 16);
277 key
= key
+ (key
<< 3);
278 key
= key
^ (key
>> 4);
279 key
= key
* 0x27d4eb2d;
280 key
= key
^ (key
>> 15);
284 key
= (~key
) + (key
<< 21); // key = (key << 21) - key - 1;
285 key
= key
^ (key
>> 24);
286 key
= (key
+ (key
<< 3)) + (key
<< 8); // key * 265
287 key
= key
^ (key
>> 14);
288 key
= (key
+ (key
<< 2)) + (key
<< 4); // key * 21
289 key
= key
^ (key
>> 28);
290 key
= key
+ (key
<< 31);
292 key
>>= 2; /* Ensure that it fits in a fixnum. */
296 /* `depth' is used to limit recursion. */
298 scm_raw_ihash (SCM obj
, size_t depth
)
301 return scm_raw_ihashq (SCM_UNPACK (obj
));
303 switch (SCM_TYP7(obj
))
305 /* FIXME: do better for structs, variables, ... Also the hashes
306 are currently associative, which ain't the right thing. */
308 return scm_raw_ihashq (SCM_TYP16 (obj
));
310 if (scm_is_integer (obj
))
312 SCM n
= SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM
);
313 if (scm_is_inexact (obj
))
314 obj
= scm_inexact_to_exact (obj
);
315 return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj
, n
)));
318 return scm_i_string_hash (scm_number_to_string (obj
, scm_from_int (10)));
320 return scm_i_string_hash (obj
);
322 return scm_i_symbol_hash (obj
);
323 case scm_tc7_pointer
:
324 return scm_raw_ihashq ((scm_t_uintptr
) SCM_POINTER_VALUE (obj
));
328 size_t len
= SCM_SIMPLE_VECTOR_LENGTH (obj
);
329 size_t i
= depth
/ 2;
330 unsigned long h
= scm_raw_ihashq (SCM_CELL_WORD_0 (obj
));
333 h
^= scm_raw_ihash (scm_c_vector_ref (obj
, h
% len
), i
);
336 case scm_tcs_cons_imcar
:
337 case scm_tcs_cons_nimcar
:
339 return (scm_raw_ihash (SCM_CAR (obj
), depth
/ 2)
340 ^ scm_raw_ihash (SCM_CDR (obj
), depth
/ 2));
342 return scm_raw_ihashq (scm_tc3_cons
);
344 return scm_i_struct_hash (obj
, depth
);
346 return scm_raw_ihashq (SCM_CELL_WORD_0 (obj
));
354 scm_ihashq (SCM obj
, unsigned long n
)
356 return scm_raw_ihashq (SCM_UNPACK (obj
)) % n
;
360 SCM_DEFINE (scm_hashq
, "hashq", 2, 0, 0,
362 "Determine a hash value for @var{key} that is suitable for\n"
363 "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
364 "used as the equality predicate. The function returns an\n"
365 "integer in the range 0 to @var{size} - 1. Note that\n"
366 "@code{hashq} may use internal addresses. Thus two calls to\n"
367 "hashq where the keys are @code{eq?} are not guaranteed to\n"
368 "deliver the same value if the key object gets garbage collected\n"
369 "in between. This can happen, for example with symbols:\n"
370 "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
371 "different values, since @code{foo} will be garbage collected.")
372 #define FUNC_NAME s_scm_hashq
374 unsigned long sz
= scm_to_unsigned_integer (size
, 1, ULONG_MAX
);
375 return scm_from_ulong (scm_ihashq (key
, sz
));
384 scm_ihashv (SCM obj
, unsigned long n
)
387 return scm_raw_ihash (obj
, 10) % n
;
389 return scm_raw_ihashq (SCM_UNPACK (obj
)) % n
;
393 SCM_DEFINE (scm_hashv
, "hashv", 2, 0, 0,
395 "Determine a hash value for @var{key} that is suitable for\n"
396 "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
397 "used as the equality predicate. The function returns an\n"
398 "integer in the range 0 to @var{size} - 1. Note that\n"
399 "@code{(hashv key)} may use internal addresses. Thus two calls\n"
400 "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
401 "deliver the same value if the key object gets garbage collected\n"
402 "in between. This can happen, for example with symbols:\n"
403 "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
404 "different values, since @code{foo} will be garbage collected.")
405 #define FUNC_NAME s_scm_hashv
407 unsigned long sz
= scm_to_unsigned_integer (size
, 1, ULONG_MAX
);
408 return scm_from_ulong (scm_ihashv (key
, sz
));
417 scm_ihash (SCM obj
, unsigned long n
)
419 return (unsigned long) scm_raw_ihash (obj
, 10) % n
;
422 SCM_DEFINE (scm_hash
, "hash", 2, 0, 0,
424 "Determine a hash value for @var{key} that is suitable for\n"
425 "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
426 "is used as the equality predicate. The function returns an\n"
427 "integer in the range 0 to @var{size} - 1.")
428 #define FUNC_NAME s_scm_hash
430 unsigned long sz
= scm_to_unsigned_integer (size
, 1, ULONG_MAX
);
431 return scm_from_ulong (scm_ihash (key
, sz
));
442 #include "libguile/hash.x"